Graph::Easy::Base - base class for Graph::Easy objects like nodes, edges etc

	package Graph::Easy::My::Node;
	use Graph::Easy::Base;
	@ISA = qw/Graph::Easy::Base/;

	my $object = Graph::Easy::Base->new();

	$last_error = $object->error();

	$object->error($error);			# set new messags
	$object->error('');			# clear the error

	my $error = $object->error_as_html();

	$object->warn('Warning!');

	$object->no_fatal_errors(1);

	$fatal = $object->fatal_errors();
	$object->fatal_errors(0);		# turn off
	$object->fatal_errors(1);		# turn on

	my $catch_errors = $object->catch_errors();	# query
	$object->catch_errors(1);			# enable

	$object->...();					# some error
	if ($object->error())
	  {
	  my @errors = $object->errors();		# retrieve
	  }

	my $catch_warns = $object->catch_warnings();	# query
	$object->catch_warnings(1);			# enable

	$object->...();					# some error
	if ($object->warning())
	  {
	  my @warnings = $object->warnings();		# retrieve
	  }

	# catch errors and warnings
	$object->catch_messages(1);
	# stop catching errors and warnings
	$object->catch_messages(0);

	$object->catch_warnings(1);
	$object->catch_errors(1);

	my @errors = $object->errors();

	my @warnings = $object->warnings();

	my $self = $object->self();

	my $class = $object->class();

	my $sub_class = $object->sub_class();

	my $main_class = $object->main_class();

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

package Graph::Easy::Base;

$VERSION = '0.12';

use strict;

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

{
  # 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/</&lt;/g;
  $msg =~ s/>/&gt;/g;
  $msg =~ s/"/&quot;/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__