view release on metacpan or  search on metacpan

lib/Graph/Easy.pm  view on Meta::CPAN

  # called like "new->('[A]->[B]')":
  if (@_ == 1 && !ref($_[0]))
    {
    require Graph::Easy::Parser;
    my $parser = Graph::Easy::Parser->new();
    my $self = eval { $parser->from_text($_[0]); };
    if (!defined $self)
      {
      $self = Graph::Easy->new( fatal_errors => 0 );
      $self->error( 'Error: ' . $parser->error() ||
        'Unknown error while parsing initial text' );
      $self->catch_errors( 0 );
      }
    return $self;
    }

  my $self = bless {}, $class;

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

  $self->_init($args);
  }

sub DESTROY
  {
  my $self = shift;

  # Be careful to not delete ->{graph}, these will be cleaned out by
  # Perl automatically in O(1) time, manual delete is O(N) instead.

  delete $self->{chains};
  # clean out pointers in child-objects so that they can safely be reused
  for my $n (ord_values ( $self->{nodes} ))
    {
    if (ref($n))
      {
      delete $n->{edges};
      delete $n->{group};
      }
    }
  for my $e (ord_values ( $self->{edges} ))
    {
    if (ref($e))
      {
      delete $e->{cells};
      delete $e->{to};
      delete $e->{from};
      }
    }
  for my $g (ord_values ( $self->{groups} ))
    {
    if (ref($g))
      {
      delete $g->{nodes};
      delete $g->{edges};
      }
    }
  }

# Attribute overlay for HTML output:

my $html_att = {
  node => {
    borderstyle => 'solid',
    borderwidth => '1px',
    bordercolor => '#000000',
    align => 'center',
    padding => '0.2em',
    'padding-left' => '0.3em',
    'padding-right' => '0.3em',
    margin => '0.1em',
    fill => 'white',
    },
  'node.anon' => {
    'borderstyle' => 'none',
    # ' inherit' to protect the value from being replaced by the one from "node"
    'background' => ' inherit',
    },
  graph => {
    margin => '0.5em',
    padding => '0.5em',
    'empty-cells' => 'show',
    },
  edge => {
    border => 'none',
    padding => '0.2em',
    margin => '0.1em',
    'font' => 'monospaced, courier-new, courier, sans-serif',
    'vertical-align' => 'bottom',
    },
  group => {
    'borderstyle' => 'dashed',
    'borderwidth' => '1',
    'fontsize' => '0.8em',
    fill => '#a0d0ff',
    padding => '0.2em',
# XXX TODO:
# in HTML, align left is default, so we could omit this:
    align => 'left',
    },
  'group.anon' => {
    'borderstyle' => 'none',
    background => 'white',
    },
  };


sub _init
  {
  my ($self,$args) = @_;

  $self->{debug} = 0;
  $self->{timeout} = 5;			# in seconds
  $self->{strict} = 1;			# check attributes strict?

  $self->{class} = 'graph';
  $self->{id} = '';
  $self->{groups} = {};

  # node objects, indexed by their unique name

lib/Graph/Easy.pm  view on Meta::CPAN

  'down' => 180,
  'back' => 270,
  'left' => 270,
  'right' => 90,
  'front' => 90,
  'forward' => 90,
  };

sub flow
  {
  # return out flow as number
  my ($self)  = @_;

  my $flow = $self->{att}->{graph}->{flow};

  return 90 unless defined $flow;

  my $f = $p_flow->{$flow}; $f = $flow unless defined $f;
  $f;
  }

#############################################################################
#############################################################################
# Output (as_ascii, as_html) routines; as_txt() is in As_txt.pm, as_graphml
# is in As_graphml.pm

sub output_format
  {
  # set the output format
  my $self = shift;

  $self->{output_format} = shift if $_[0];
  $self->{output_format};
  }

sub output
  {
  # general output routine, to output the graph as the format that was
  # specified in the graph source itself
  my $self = shift;

  no strict 'refs';

  my $method = 'as_' . $self->{output_format};

  $self->_croak("Cannot find a method to generate '$self->{output_format}'")
    unless $self->can($method);

  $self->$method();
  }

sub _class_styles
  {
  # Create the style sheet with the class lists. This is used by both
  # css() and as_svg(). $skip is a qr// object that returns true for
  # attribute names to be skipped (e.g. excluded), and $map is a
  # HASH that contains mapping for attribute names for the output.
  # "$base" is the basename for classes (either "table.graph$id" if
  # not defined, or whatever you pass in, like "" for svg).
  # $indent is a left-indenting spacer like "  ".
  # $overlay contains a HASH with attribute-value pairs to set as defaults.

  my ($self, $skip, $map, $base, $indent, $overlay) = @_;

  my $a = $self->{att};

  $indent = '' unless defined $indent;
  my $indent2 = $indent x 2; $indent2 = '  ' if $indent2 eq '';

  my $class_list = { edge => {}, node => {}, group => {} };
  if (defined $overlay)
    {
    $a = {};

    # make a copy from $self->{att} to $a:

    for my $class (sort keys %{$self->{att}})
      {
      my $ac = $self->{att}->{$class};
      $a->{$class} = {};
      my $acc = $a->{$class};
      for my $k (sort keys %$ac)
        {
        $acc->{$k} = $ac->{$k};
        }
      }

    # add the extra keys
    for my $class (sort keys %$overlay)
      {
      my $oc = $overlay->{$class};
      # create the hash if it doesn't exist yet
      $a->{$class} = {} unless ref $a->{$class};
      my $acc = $a->{$class};
      for my $k (sort keys %$oc)
        {
        $acc->{$k} = $oc->{$k} unless exists $acc->{$k};
        }
      $class_list->{$class} = {};
      }
    }

  my $id = $self->{id};

  my @primaries = sort keys %$class_list;
  foreach my $primary (@primaries)
    {
    my $cl = $class_list->{$primary};			# shortcut
    foreach my $class (sort keys %$a)
      {
      if ($class =~ /^$primary\.(.*)/)
        {
        $cl->{$1} = undef;				# note w/o doubles
        }
      }
    }

  $base = "table.graph$id " unless defined $base;

  my $groups = $self->groups();				# do we have groups?

  my $css = '';
  foreach my $class (sort keys %$a)
    {
    next if (not %{$a->{$class}});			# skip empty ones

    my $c = $class; $c =~ s/\./_/g;			# node.city => node_city

    next if $class eq 'group' and $groups == 0;

    my $css_txt = '';
    my $cls = '';
    if ($class eq 'graph' && $base eq '')
      {
      $css_txt .= "${indent}.$class \{\n";			# for SVG
      }
    elsif ($class eq 'graph')
      {
      $css_txt .= "$indent$base\{\n";
      }
    else
      {
      if ($c !~ /\./)					# one of our primary ones
        {
        # generate also class list 			# like: "cities,node_rivers"
        $cls = join (",$base.${c}_", sort keys %{ $class_list->{$c} });
        $cls = ",$base.${c}_$cls" if $cls ne '';		# like: ",node_cities,node_rivers"
        }
      $css_txt .= "$indent$base.$c$cls {\n";
      }
    my $done = 0;