File Coverage

lib/Graph/Easy/Base.pm

Criterion	Covered	Total	%
statement	99	120	82.5
branch	50	70	71.4
condition	8	14	57.1
subroutine	18	21	85.7
pod	15	15	100.0
total	190	240	79.1

#############################################################################
# A baseclass for Graph::Easy objects like nodes, edges etc.
#
#############################################################################

package Graph::Easy::Base;

$VERSION = '0.75';

use strict;
use warnings;

#############################################################################

{
  # protected vars
  my $id = 0;
  sub _new_id { $id++; }
  sub _reset_id { $id = 0; }
}

#############################################################################

sub new
  {
  # Create a new object. This is a generic routine that is inherited
  # by many other things like Edge, Cell etc.
  my $self = bless { id => _new_id() }, shift;

  my $args = $_[0];
  $args = { name => $_[0] } if ref($args) ne 'HASH' && @_ == 1;
  $args = { @_ } if ref($args) ne 'HASH' && @_ > 1;

  $self->_init($args);
  }

sub _init
  {
  # Generic init routine, to be overriden in subclasses.
  my ($self,$args) = @_;

  $self;
  }

sub self
  {
  my $self = shift;

  $self;
  }

#############################################################################

sub no_fatal_errors
  {
  my $self = shift;

  $self->{fatal_errors} = ($_[1] ? 1 : 0) if @_ > 0;

  ~ ($self->{fatal_errors} || 0);
  }

sub fatal_errors
  {
  my $self = shift;

  $self->{fatal_errors} = ($_[1] ? 0 : 1) if @_ > 0;

  $self->{fatal_errors} || 0;
  }

sub error
  {
  my $self = shift;

  # If we switched to a temp. Graphviz parser, then set the error on the
  # original parser object, too:
  $self->{_old_self}->error(@_) if ref($self->{_old_self});

  # if called on a member on a graph, call error() on the graph itself:
  return $self->{graph}->error(@_) if ref($self->{graph});

  if (defined $_[0])
    {
    $self->{error} = $_[0];
    if ($self->{_catch_errors})
      {
      push @{$self->{_errors}}, $self->{error};
      }
    else
      {
      $self->_croak($self->{error}, 2)
        if ($self->{fatal_errors}) && $self->{error} ne '';
      }
    }
  $self->{error} || '';
  }

sub error_as_html
  {
  # return error() properly escaped
  my $self = shift;

  my $msg = $self->{error};

  $msg =~ s/&/&/g;
  $msg =~ s/
  $msg =~ s/>/>/g;
  $msg =~ s/"/"/g;

  $msg;
  }

sub catch_messages
  {
  # Catch all warnings (and errors if no_fatal_errors() was used)
  # these can later be retrieved with warnings() and errors():
  my $self = shift;

  if (@_ > 0)
    {
    if ($_[0])
      {
      $self->{_catch_warnings} = 1;
      $self->{_catch_errors} = 1;
      $self->{_warnings} = [];
      $self->{_errors} = [];
      }
    else
      {
      $self->{_catch_warnings} = 0;
      $self->{_catch_errors} = 0;
      }
    }
  $self;
  }

sub catch_warnings
  {
  # Catch all warnings
  # these can later be retrieved with warnings():
  my $self = shift;

  if (@_ > 0)
    {
    if ($_[0])
      {
      $self->{_catch_warnings} = 1;
      $self->{_warnings} = [];
      }
    else
      {
      $self->{_catch_warnings} = 0;
      }
    }
  $self->{_catch_warnings};
  }

sub catch_errors
  {
  # Catch all errors
  # these can later be retrieved with errors():
  my $self = shift;

  if (@_ > 0)
    {
    if ($_[0])
      {
      $self->{_catch_errors} = 1;
      $self->{_errors} = [];
      }
    else
      {
      $self->{_catch_errors} = 0;
      }
    }
  $self->{_catch_errors};
  }

sub warnings
  {
  # return all warnings that occured after catch_messages(1)
  my $self = shift;

  @{$self->{_warnings}};
  }

sub errors
  {
  # return all errors that occured after catch_messages(1)
  my $self = shift;

  @{$self->{_errors}};
  }

sub warn
  {
  my ($self, $msg) = @_;

  if ($self->{_catch_warnings})
    {
    push @{$self->{_warnings}}, $msg;
    }
  else
    {
    require Carp;
    Carp::carp('Warning: ' . $msg);
    }
  }

sub _croak
  {
  my ($self, $msg, $level) = @_;
  $level = 1 unless defined $level;

  require Carp;
  if (ref($self) && $self->{debug})
    {
    $Carp::CarpLevel = $level;			# don't report Base itself
    Carp::confess($msg);
    }
  else
    {
    Carp::croak($msg);
    }
  }

#############################################################################
# class management

sub sub_class
  {
  # get/set the subclass
  my $self = shift;

  if (defined $_[0])
    {
    $self->{class} =~ s/\..*//;		# nix subclass
    $self->{class} .= '.' . $_[0];	# append new one
    delete $self->{cache};
    $self->{cache}->{subclass} = $_[0];
    $self->{cache}->{class} = $self->{class};
    return;
    }
  $self->{class} =~ /\.(.*)/;

  return $1 if defined $1;

  return $self->{cache}->{subclass} if defined $self->{cache}->{subclass};

  # Subclass not defined, so check our base class for a possible set class
  # attribute and return this:

  # take a shortcut
  my $g = $self->{graph};
  if (defined $g)
    {
    my $subclass = $g->{att}->{$self->{class}}->{class};
    $subclass = '' unless defined $subclass;
    $self->{cache}->{subclass} = $subclass;
    $self->{cache}->{class} = $self->{class};
    return $subclass;
    }

  # not part of a graph?
  $self->{cache}->{subclass} = $self->attribute('class');
  }

sub class
  {
  # return our full class name like "node.subclass" or "node"
  my $self = shift;

  $self->error("class() method does not take arguments") if @_ > 0;

  $self->{class} =~ /\.(.*)/;

  return $self->{class} if defined $1;

  return $self->{cache}->{class} if defined $self->{cache}->{class};

  # Subclass not defined, so check our base class for a possible set class
  # attribute and return this:

  my $subclass;
  # take a shortcut:
  my $g = $self->{graph};
  if (defined $g)
    {
    $subclass = $g->{att}->{$self->{class}}->{class};
    $subclass = '' unless defined $subclass;
    }

  $subclass = $self->{att}->{class} unless defined $subclass;
  $subclass = '' unless defined $subclass;
  $self->{cache}->{subclass} = $subclass;
  $subclass = '.' . $subclass if $subclass ne '';

  $self->{cache}->{class} = $self->{class} . $subclass;
  }

sub main_class
  {
  my $self = shift;

  $self->{class} =~ /^(.+?)(\.|\z)/;	# extract first part

  $1;
  }

1;
__END__