1779 lines
47 KiB
Perl
1779 lines
47 KiB
Perl
#############################################################################
|
|
# Parse text definition into a Graph::Easy object
|
|
#
|
|
#############################################################################
|
|
|
|
package Graph::Easy::Parser;
|
|
|
|
use Graph::Easy;
|
|
|
|
$VERSION = '0.76';
|
|
use Graph::Easy::Base;
|
|
@ISA = qw/Graph::Easy::Base/;
|
|
use Scalar::Util qw/weaken/;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use constant NO_MULTIPLES => 1;
|
|
|
|
use Graph::Easy::Util qw(ord_values);
|
|
|
|
sub _init
|
|
{
|
|
my ($self,$args) = @_;
|
|
|
|
$self->{error} = '';
|
|
$self->{debug} = 0;
|
|
$self->{fatal_errors} = 1;
|
|
|
|
foreach my $k (sort keys %$args)
|
|
{
|
|
if ($k !~ /^(debug|fatal_errors)\z/)
|
|
{
|
|
require Carp;
|
|
my $class = ref($self);
|
|
Carp::confess ("Invalid argument '$k' passed to $class" . '->new()');
|
|
}
|
|
$self->{$k} = $args->{$k};
|
|
}
|
|
|
|
# what to replace the matched text with
|
|
$self->{replace} = '';
|
|
$self->{attr_sep} = ':';
|
|
# An optional regexp to remove parts of an autosplit label, used by Graphviz
|
|
# to remove " <p1> ":
|
|
$self->{_qr_part_clean} = undef;
|
|
|
|
# setup default class names for generated objects
|
|
$self->{use_class} = {
|
|
edge => 'Graph::Easy::Edge',
|
|
group => 'Graph::Easy::Group',
|
|
graph => 'Graph::Easy',
|
|
node => 'Graph::Easy::Node',
|
|
};
|
|
|
|
$self;
|
|
}
|
|
|
|
sub reset
|
|
{
|
|
# reset the status of the parser, clear errors etc.
|
|
my $self = shift;
|
|
|
|
$self->{error} = '';
|
|
$self->{anon_id} = 0;
|
|
$self->{cluster_id} = ''; # each cluster gets a unique ID
|
|
$self->{line_nr} = -1;
|
|
$self->{match_stack} = []; # patterns and their handlers
|
|
|
|
$self->{clusters} = {}; # cluster names we already created
|
|
|
|
Graph::Easy::Base::_reset_id(); # start with the same set of IDs
|
|
|
|
# After "[ 1 ] -> [ 2 ]" we push "2" on the stack and when we encounter
|
|
# " -> [ 3 ]" treat the stack as a node-list left of "3".
|
|
# In addition, for " [ 1 ], [ 2 ] => [ 3 ]", the stack will contain
|
|
# "1" and "2" when we encounter "3".
|
|
$self->{stack} = [];
|
|
|
|
$self->{group_stack} = []; # all the (nested) groups we are currently in
|
|
$self->{left_stack} = []; # stack for the left side for "[]->[],[],..."
|
|
$self->{left_edge} = undef; # for -> [A], [B] continuations
|
|
|
|
Graph::Easy->_drop_special_attributes();
|
|
|
|
$self->{_graph} = $self->{use_class}->{graph}->new( {
|
|
debug => $self->{debug},
|
|
strict => 0,
|
|
fatal_errors => $self->{fatal_errors},
|
|
} );
|
|
|
|
$self;
|
|
}
|
|
|
|
sub from_file
|
|
{
|
|
# read in entire file and call from_text() on the contents
|
|
my ($self,$file) = @_;
|
|
|
|
$self = $self->new() unless ref $self;
|
|
|
|
my $doc;
|
|
local $/ = undef; # slurp mode
|
|
# if given a reference, assume it is a glob, or something like that
|
|
if (ref($file))
|
|
{
|
|
binmode $file, ':utf8' or die ("binmode '$file', ':utf8' failed: $!");
|
|
$doc = <$file>;
|
|
}
|
|
else
|
|
{
|
|
open my $PARSER_FILE, $file or die (ref($self).": Cannot read $file: $!");
|
|
binmode $PARSER_FILE, ':utf8' or die ("binmode '$file', ':utf8' failed: $!");
|
|
$doc = <$PARSER_FILE>; # read entire file
|
|
close $PARSER_FILE;
|
|
}
|
|
|
|
$self->from_text($doc);
|
|
}
|
|
|
|
sub use_class
|
|
{
|
|
# use the provided class for generating objects of the type $object
|
|
my ($self, $object, $class) = @_;
|
|
|
|
$self->_croak("Expected one of node, edge, group or graph, but got $object")
|
|
unless $object =~ /^(node|group|graph|edge)\z/;
|
|
|
|
$self->{use_class}->{$object} = $class;
|
|
|
|
$self;
|
|
}
|
|
|
|
sub _register_handler
|
|
{
|
|
# register a pattern and a handler for it
|
|
my $self = shift;
|
|
|
|
push @{$self->{match_stack}}, [ @_ ];
|
|
|
|
$self;
|
|
}
|
|
|
|
sub _register_attribute_handler
|
|
{
|
|
# register a handler for attributes like "{ color: red; }"
|
|
my ($self, $qr_attr, $target) = @_;
|
|
|
|
# $object is either undef (for Graph::Easy, meaning "node", or "parent" for Graphviz)
|
|
|
|
# { attributes }
|
|
$self->_register_handler( qr/^$qr_attr/,
|
|
sub
|
|
{
|
|
my $self = shift;
|
|
# This happens in the case of "[ Test ]\n { ... }", the node is consumed
|
|
# first, and the attributes are left over:
|
|
|
|
my $stack = $self->{stack}; $stack = $self->{group_stack} if @{$self->{stack}} == 0;
|
|
|
|
my $object = $target;
|
|
if ($target && $target eq 'parent')
|
|
{
|
|
# for Graphviz, stray attributes always apply to the parent
|
|
$stack = $self->{group_stack};
|
|
|
|
$object = $stack->[-1] if ref $stack;
|
|
if (!defined $object)
|
|
{
|
|
# try the scope stack next:
|
|
$stack = $self->{scope_stack};
|
|
$object = $self->{_graph};
|
|
if (!$stack || @$stack <= 1)
|
|
{
|
|
$object = $self->{_graph};
|
|
$stack = [ $self->{_graph} ];
|
|
}
|
|
}
|
|
}
|
|
my ($a, $max_idx) = $self->_parse_attributes($1||'', $object);
|
|
return undef if $self->{error}; # wrong attributes or empty stack?
|
|
|
|
if (ref($stack->[-1]) eq 'HASH')
|
|
{
|
|
# stack is a scope stack
|
|
# XXX TODO: Find out wether the attribute goes to graph, node or edge
|
|
for my $k (sort keys %$a)
|
|
{
|
|
$stack->[-1]->{graph}->{$k} = $a->{$k};
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
print STDERR "max_idx = $max_idx, stack contains ", join (" , ", @$stack),"\n"
|
|
if $self->{debug} && $self->{debug} > 1;
|
|
if ($max_idx != 1)
|
|
{
|
|
my $i = 0;
|
|
for my $n (@$stack)
|
|
{
|
|
$n->set_attributes($a, $i++);
|
|
}
|
|
}
|
|
else
|
|
{
|
|
# set attributes on all nodes/groups on stack
|
|
for my $n (@$stack) { $n->set_attributes($a); }
|
|
}
|
|
# This happens in the case of "[ a | b ]\n { ... }", the node is consumed
|
|
# first, and the attributes are left over. And if we encounter a basename
|
|
# attribute here, the node-parts will already have been created with the
|
|
# wrong basename, so correct this:
|
|
if (defined $a->{basename})
|
|
{
|
|
for my $s (@$stack)
|
|
{
|
|
# for every node on the stack that is the primary one
|
|
$self->_set_new_basename($s, $a->{basename}) if exists $s->{autosplit_parts};
|
|
}
|
|
}
|
|
1;
|
|
} );
|
|
}
|
|
|
|
sub _register_node_attribute_handler
|
|
{
|
|
# register a handler for attributes like "[ A ] { ... }"
|
|
my ($self, $qr_node, $qr_oatr) = @_;
|
|
|
|
$self->_register_handler( qr/^$qr_node$qr_oatr/,
|
|
sub
|
|
{
|
|
my $self = shift;
|
|
my $n1 = $1;
|
|
my $a1 = $self->_parse_attributes($2||'');
|
|
return undef if $self->{error};
|
|
|
|
$self->{stack} = [ $self->_new_node ($self->{_graph}, $n1, $self->{group_stack}, $a1) ];
|
|
|
|
# forget left stack
|
|
$self->{left_edge} = undef;
|
|
$self->{left_stack} = [];
|
|
1;
|
|
} );
|
|
}
|
|
|
|
sub _new_group
|
|
{
|
|
# create a new (possible anonymous) group
|
|
my ($self, $name) = @_;
|
|
|
|
$name = '' unless defined $name;
|
|
|
|
my $gr = $self->{use_class}->{group};
|
|
|
|
my $group;
|
|
|
|
if ($name eq '')
|
|
{
|
|
print STDERR "# Creating new anon group.\n" if $self->{debug};
|
|
$gr .= '::Anon';
|
|
$group = $gr->new();
|
|
}
|
|
else
|
|
{
|
|
$name = $self->_unquote($name);
|
|
print STDERR "# Creating new group '$name'.\n" if $self->{debug};
|
|
$group = $gr->new( name => $name );
|
|
}
|
|
|
|
$self->{_graph}->add_group($group);
|
|
|
|
my $group_stack = $self->{group_stack};
|
|
if (@$group_stack > 0)
|
|
{
|
|
$group->set_attribute('group', $group_stack->[-1]->{name});
|
|
}
|
|
|
|
$group;
|
|
}
|
|
|
|
sub _add_group_match
|
|
{
|
|
# register two handlers for group start/end
|
|
my $self = shift;
|
|
|
|
my $qr_group_start = $self->_match_group_start();
|
|
my $qr_group_end = $self->_match_group_end();
|
|
my $qr_oatr = $self->_match_optional_attributes();
|
|
|
|
# "( group start [" or empty group like "( Group )"
|
|
$self->_register_handler( qr/^$qr_group_start/,
|
|
sub
|
|
{
|
|
my $self = shift;
|
|
my $graph = $self->{_graph};
|
|
|
|
my $end = $2; $end = '' unless defined $end;
|
|
|
|
# repair the start of the next node/group
|
|
$self->{replace} = '[' if $end eq '[';
|
|
$self->{replace} = '(' if $end eq '(';
|
|
|
|
# create the new group
|
|
my $group = $self->_new_group($1);
|
|
|
|
if ($end eq ')')
|
|
{
|
|
# we matched an empty group like "()", or "( group name )"
|
|
$self->{stack} = [ $group ];
|
|
print STDERR "# Seen end of group '$group->{name}'.\n" if $self->{debug};
|
|
}
|
|
else
|
|
{
|
|
# only put the group on the stack if it is still open
|
|
push @{$self->{group_stack}}, $group;
|
|
}
|
|
|
|
1;
|
|
} );
|
|
|
|
# ") { }" # group end (with optional attributes)
|
|
$self->_register_handler( qr/^$qr_group_end$qr_oatr/,
|
|
sub
|
|
{
|
|
my $self = shift;
|
|
|
|
my $group = pop @{$self->{group_stack}};
|
|
return $self->parse_error(0) if !defined $group;
|
|
|
|
print STDERR "# Seen end of group '$group->{name}'.\n" if $self->{debug};
|
|
|
|
my $a1 = $self->_parse_attributes($1||'', 'group', NO_MULTIPLES);
|
|
return undef if $self->{error};
|
|
|
|
$group->set_attributes($a1);
|
|
|
|
# the new left side is the group itself
|
|
$self->{stack} = [ $group ];
|
|
1;
|
|
} );
|
|
|
|
}
|
|
|
|
sub _build_match_stack
|
|
{
|
|
# put all known patterns and their handlers on the match stack
|
|
my $self = shift;
|
|
|
|
# regexps for the different parts
|
|
my $qr_node = $self->_match_node();
|
|
my $qr_attr = $self->_match_attributes();
|
|
my $qr_oatr = $self->_match_optional_attributes();
|
|
my $qr_edge = $self->_match_edge();
|
|
my $qr_comma = $self->_match_comma();
|
|
my $qr_class = $self->_match_class_selector();
|
|
|
|
my $e = $self->{use_class}->{edge};
|
|
|
|
# node { color: red; }
|
|
# node.graph { ... }
|
|
# .foo { ... }
|
|
# .foo, node, edge.red { ... }
|
|
$self->_register_handler( qr/^\s*$qr_class$qr_attr/,
|
|
sub
|
|
{
|
|
my $self = shift;
|
|
my $class = lc($1 || '');
|
|
my $att = $self->_parse_attributes($2 || '', $class, NO_MULTIPLES );
|
|
|
|
return undef unless defined $att; # error in attributes?
|
|
|
|
my $graph = $self->{_graph};
|
|
$graph->set_attributes ( $class, $att);
|
|
|
|
# forget stacks
|
|
$self->{stack} = [];
|
|
$self->{left_edge} = undef;
|
|
$self->{left_stack} = [];
|
|
1;
|
|
} );
|
|
|
|
$self->_add_group_match();
|
|
|
|
$self->_register_attribute_handler($qr_attr);
|
|
$self->_register_node_attribute_handler($qr_node,$qr_oatr);
|
|
|
|
# , [ Berlin ] { color: red; }
|
|
$self->_register_handler( qr/^$qr_comma$qr_node$qr_oatr/,
|
|
sub
|
|
{
|
|
my $self = shift;
|
|
my $graph = $self->{_graph};
|
|
my $n1 = $1;
|
|
my $a1 = $self->_parse_attributes($2||'');
|
|
return undef if $self->{error};
|
|
|
|
push @{$self->{stack}},
|
|
$self->_new_node ($graph, $n1, $self->{group_stack}, $a1, $self->{stack});
|
|
|
|
if (defined $self->{left_edge})
|
|
{
|
|
my ($style, $edge_label, $edge_atr, $edge_bd, $edge_un) = @{$self->{left_edge}};
|
|
|
|
foreach my $node (@{$self->{left_stack}})
|
|
{
|
|
my $edge = $e->new( { style => $style, name => $edge_label } );
|
|
$edge->set_attributes($edge_atr);
|
|
# "<--->": bidirectional
|
|
$edge->bidirectional(1) if $edge_bd;
|
|
$edge->undirected(1) if $edge_un;
|
|
$graph->add_edge ( $node, $self->{stack}->[-1], $edge );
|
|
}
|
|
}
|
|
1;
|
|
} );
|
|
|
|
# Things like "[ Node ]" will be consumed before, so we do not need a case
|
|
# for "[ A ] -> [ B ]":
|
|
# node chain continued like "-> { ... } [ Kassel ] { ... }"
|
|
$self->_register_handler( qr/^$qr_edge$qr_oatr$qr_node$qr_oatr/,
|
|
sub
|
|
{
|
|
my $self = shift;
|
|
|
|
return if @{$self->{stack}} == 0; # only match this if stack non-empty
|
|
|
|
my $graph = $self->{_graph};
|
|
my $eg = $1; # entire edge ("-- label -->" etc)
|
|
|
|
my $edge_bd = $2 || $4; # bidirectional edge ('<') ?
|
|
my $edge_un = 0; # undirected edge?
|
|
$edge_un = 1 if !defined $2 && !defined $5;
|
|
|
|
# optional edge label
|
|
my $edge_label = $7;
|
|
my $ed = $3 || $5 || $1; # edge pattern/style ("--")
|
|
|
|
my $edge_atr = $11 || ''; # save edge attributes
|
|
|
|
my $n = $12; # node name
|
|
my $a1 = $self->_parse_attributes($13||''); # node attributes
|
|
|
|
$edge_atr = $self->_parse_attributes($edge_atr, 'edge');
|
|
return undef if $self->{error};
|
|
|
|
# allow undefined edge labels for setting them from the class
|
|
# strip trailing spaces and convert \[ => [
|
|
$edge_label = $self->_unquote($edge_label) if defined $edge_label;
|
|
# strip trailing spaces
|
|
$edge_label =~ s/\s+\z// if defined $edge_label;
|
|
|
|
# the right side node(s) (multiple in case of autosplit)
|
|
my $nodes_b = [ $self->_new_node ($self->{_graph}, $n, $self->{group_stack}, $a1) ];
|
|
|
|
my $style = $self->_link_lists( $self->{stack}, $nodes_b,
|
|
$ed, $edge_label, $edge_atr, $edge_bd, $edge_un);
|
|
|
|
# remember the left side
|
|
$self->{left_edge} = [ $style, $edge_label, $edge_atr, $edge_bd, $edge_un ];
|
|
$self->{left_stack} = $self->{stack};
|
|
|
|
# forget stack and remember the right side instead
|
|
$self->{stack} = $nodes_b;
|
|
1;
|
|
} );
|
|
|
|
my $qr_group_start = $self->_match_group_start();
|
|
|
|
# Things like ")" will be consumed before, so we do not need a case
|
|
# for ") -> { ... } ( Group [ B ]":
|
|
# edge to a group like "-> { ... } ( Group ["
|
|
$self->_register_handler( qr/^$qr_edge$qr_oatr$qr_group_start/,
|
|
sub
|
|
{
|
|
my $self = shift;
|
|
|
|
return if @{$self->{stack}} == 0; # only match this if stack non-empty
|
|
|
|
my $eg = $1; # entire edge ("-- label -->" etc)
|
|
|
|
my $edge_bd = $2 || $4; # bidirectional edge ('<') ?
|
|
my $edge_un = 0; # undirected edge?
|
|
$edge_un = 1 if !defined $2 && !defined $5;
|
|
|
|
# optional edge label
|
|
my $edge_label = $7;
|
|
my $ed = $3 || $5 || $1; # edge pattern/style ("--")
|
|
|
|
my $edge_atr = $11 || ''; # save edge attributes
|
|
|
|
my $gn = $12;
|
|
# matched "-> ( Group [" or "-> ( Group ("
|
|
$self->{replace} = '[' if defined $13 && $13 eq '[';
|
|
$self->{replace} = '(' if defined $13 && $13 eq '(';
|
|
|
|
$edge_atr = $self->_parse_attributes($edge_atr, 'edge');
|
|
return undef if $self->{error};
|
|
|
|
# get the last group of the stack, lest the new one gets nested in it
|
|
pop @{$self->{group_stack}};
|
|
|
|
$self->{group_stack} = [ $self->_new_group($gn) ];
|
|
|
|
# allow undefined edge labels for setting them from the class
|
|
$edge_label = $self->_unquote($edge_label) if $edge_label;
|
|
# strip trailing spaces
|
|
$edge_label =~ s/\s+\z// if $edge_label;
|
|
|
|
my $style = $self->_link_lists( $self->{stack}, $self->{group_stack},
|
|
$ed, $edge_label, $edge_atr, $edge_bd, $edge_un);
|
|
|
|
# remember the left side
|
|
$self->{left_edge} = [ $style, $edge_label, $edge_atr, $edge_bd, $edge_un ];
|
|
$self->{left_stack} = $self->{stack};
|
|
# forget stack
|
|
$self->{stack} = [];
|
|
# matched "->()" so remember the group on the stack
|
|
$self->{stack} = [ $self->{group_stack}->[-1] ] if defined $13 && $13 eq ')';
|
|
|
|
1;
|
|
} );
|
|
}
|
|
|
|
sub _line_insert
|
|
{
|
|
# what to insert between two lines, '' for Graph::Easy, ' ' for Graphviz;
|
|
'';
|
|
}
|
|
|
|
sub _clean_line
|
|
{
|
|
# do some cleanups on a line before handling it
|
|
my ($self,$line) = @_;
|
|
|
|
chomp($line);
|
|
|
|
# convert #808080 into \#808080, and "#fff" into "\#fff"
|
|
my $sep = $self->{attr_sep};
|
|
$line =~ s/$sep\s*("?)(#(?:[a-fA-F0-9]{6}|[a-fA-F0-9]{3}))("?)/$sep $1\\$2$3/g;
|
|
|
|
# remove comment at end of line (but leave \# alone):
|
|
$line =~ s/(:[^\\]|)$self->{qr_comment}.*/$1/;
|
|
|
|
# remove white space at end (but not at the start, to keep " ||" intact
|
|
$line =~ s/\s+\z//;
|
|
|
|
# print STDERR "# at line '$line' stack: ", join(",",@{ $self->{stack}}),"\n";
|
|
|
|
$line;
|
|
}
|
|
|
|
sub from_text
|
|
{
|
|
my ($self,$txt) = @_;
|
|
|
|
# matches a multi-line comment
|
|
my $o_cmt = qr#((\s*/\*.*?\*/\s*)*\s*|\s+)#;
|
|
|
|
if ((ref($self)||$self) eq 'Graph::Easy::Parser' &&
|
|
# contains "digraph GRAPH {" or something similar
|
|
( $txt =~ /^(\s*|\s*\/\*.*?\*\/\s*)(strict)?$o_cmt(di)?graph$o_cmt("[^"]*"|[\w_]+)$o_cmt\{/im ||
|
|
# contains "digraph {" or something similar
|
|
$txt =~ /^(\s*|\s*\/\*.*?\*\/\s*)(strict)?${o_cmt}digraph$o_cmt\{/im ||
|
|
# contains "strict graph {" or something similar
|
|
$txt =~ /^(\s*|\s*\/\*.*?\*\/\s*)strict${o_cmt}(di)?graph$o_cmt\{/im))
|
|
{
|
|
require Graph::Easy::Parser::Graphviz;
|
|
# recreate ourselfes, and pass our arguments along
|
|
my $debug = 0;
|
|
my $old_self = $self;
|
|
if (ref($self))
|
|
{
|
|
$debug = $self->{debug};
|
|
$self->{fatal_errors} = 0;
|
|
}
|
|
$self = Graph::Easy::Parser::Graphviz->new( debug => $debug, fatal_errors => 0 );
|
|
$self->reset();
|
|
$self->{_old_self} = $old_self if ref($self);
|
|
}
|
|
|
|
if ((ref($self)||$self) eq 'Graph::Easy::Parser' &&
|
|
# contains "graph: {"
|
|
$txt =~ /^([\s\n\t]*|\s*\/\*.*?\*\/\s*)graph\s*:\s*\{/m)
|
|
{
|
|
require Graph::Easy::Parser::VCG;
|
|
# recreate ourselfes, and pass our arguments along
|
|
my $debug = 0;
|
|
my $old_self = $self;
|
|
if (ref($self))
|
|
{
|
|
$debug = $self->{debug};
|
|
$self->{fatal_errors} = 0;
|
|
}
|
|
$self = Graph::Easy::Parser::VCG->new( debug => $debug, fatal_errors => 0 );
|
|
$self->reset();
|
|
$self->{_old_self} = $old_self if ref($self);
|
|
}
|
|
|
|
$self = $self->new() unless ref $self;
|
|
$self->reset();
|
|
|
|
my $graph = $self->{_graph};
|
|
return $graph if !defined $txt || $txt =~ /^\s*\z/; # empty text?
|
|
|
|
my $uc = $self->{use_class};
|
|
|
|
# instruct the graph to use the custom classes, too
|
|
for my $o (sort keys %$uc)
|
|
{
|
|
$graph->use_class($o, $uc->{$o}) unless $o eq 'graph'; # group, node and edge
|
|
}
|
|
|
|
my @lines = split /(\r\n|\n|\r)/, $txt;
|
|
|
|
my $backbuffer = ''; # left over fragments to be combined with next line
|
|
|
|
my $qr_comment = $self->_match_commented_line();
|
|
$self->{qr_comment} = $self->_match_comment();
|
|
# cache the value of this since it can be expensive to construct:
|
|
$self->{_match_single_attribute} = $self->_match_single_attribute();
|
|
|
|
$self->_build_match_stack();
|
|
|
|
###########################################################################
|
|
# main parsing loop
|
|
|
|
my $handled = 0; # did we handle a fragment?
|
|
my $line;
|
|
|
|
# my $counts = {};
|
|
LINE:
|
|
while (@lines > 0 || $backbuffer ne '')
|
|
{
|
|
# only accumulate more text if we didn't handle a fragment
|
|
if (@lines > 0 && $handled == 0)
|
|
{
|
|
$self->{line_nr}++;
|
|
my $curline = shift @lines;
|
|
|
|
# discard empty lines, or completely commented out lines
|
|
next if $curline =~ $qr_comment;
|
|
|
|
# convert tabs to spaces (the regexps don't expect tabs)
|
|
$curline =~ tr/\t/ /;
|
|
|
|
# combine backbuffer, what to insert between two lines and next line:
|
|
$line = $backbuffer . $self->_line_insert() . $self->_clean_line($curline);
|
|
}
|
|
|
|
print STDERR "# Line is '$line'\n" if $self->{debug} && $self->{debug} > 2;
|
|
print STDERR "# Backbuffer is '$backbuffer'\n" if $self->{debug} && $self->{debug} > 2;
|
|
|
|
$handled = 0;
|
|
#debug my $count = 0;
|
|
PATTERN:
|
|
for my $entry (@{$self->{match_stack}})
|
|
{
|
|
# nothing to match against?
|
|
last PATTERN if $line eq '';
|
|
|
|
$self->{replace} = ''; # as default just remove the matched text
|
|
my ($pattern, $handler, $replace) = @$entry;
|
|
|
|
print STDERR "# Matching against $pattern\n" if $self->{debug} && $self->{debug} > 3;
|
|
|
|
if ($line =~ $pattern)
|
|
{
|
|
#debug $counts->{$count}++;
|
|
print STDERR "# Matched, calling handler\n" if $self->{debug} && $self->{debug} > 2;
|
|
my $rc = 1;
|
|
$rc = &$handler($self) if defined $handler;
|
|
if ($rc)
|
|
{
|
|
$replace = $self->{replace} unless defined $replace;
|
|
$replace = &$replace($self,$line) if ref($replace);
|
|
print STDERR "# Handled it successfully.\n" if $self->{debug} && $self->{debug} > 2;
|
|
$line =~ s/$pattern/$replace/;
|
|
print STDERR "# Line is now '$line' (replaced with '$replace')\n" if $self->{debug} && $self->{debug} > 2;
|
|
$handled++; last PATTERN;
|
|
}
|
|
}
|
|
#debug $count ++;
|
|
|
|
}
|
|
|
|
#debug if ($handled == 0) { $counts->{'-1'}++; }
|
|
# couldn't handle that fragment, so accumulate it and try again
|
|
$backbuffer = $line;
|
|
|
|
# stop at the very last line
|
|
last LINE if $handled == 0 && @lines == 0;
|
|
|
|
# stop at parsing errors
|
|
last LINE if $self->{error};
|
|
}
|
|
|
|
$self->error("'$backbuffer' not recognized by " . ref($self)) if $backbuffer ne '';
|
|
|
|
# if something was left on the stack, file ended unexpectedly
|
|
$self->parse_error(7) if !$self->{error} && $self->{scope_stack} && @{$self->{scope_stack}} > 0;
|
|
|
|
return undef if $self->{error} && $self->{fatal_errors};
|
|
|
|
#debug use Data::Dumper; print Dumper($counts);
|
|
|
|
print STDERR "# Parsing done.\n" if $graph->{debug};
|
|
|
|
# Do final cleanup (for parsing Graphviz)
|
|
$self->_parser_cleanup() if $self->can('_parser_cleanup');
|
|
$graph->_drop_special_attributes();
|
|
|
|
# turn on strict checking on returned graph
|
|
$graph->strict(1);
|
|
$graph->fatal_errors(1);
|
|
|
|
$graph;
|
|
}
|
|
|
|
#############################################################################
|
|
# internal routines
|
|
|
|
sub _edge_style
|
|
{
|
|
my ($self, $ed) = @_;
|
|
|
|
my $style = undef; # default is "inherit from class"
|
|
$style = 'double-dash' if $ed =~ /^(= )+\z/;
|
|
$style = 'double' if $ed =~ /^=+\z/;
|
|
$style = 'dotted' if $ed =~ /^\.+\z/;
|
|
$style = 'dashed' if $ed =~ /^(- )+\z/;
|
|
$style = 'dot-dot-dash' if $ed =~ /^(..-)+\z/;
|
|
$style = 'dot-dash' if $ed =~ /^(\.-)+\z/;
|
|
$style = 'wave' if $ed =~ /^\~+\z/;
|
|
$style = 'bold' if $ed =~ /^#+\z/;
|
|
|
|
$style;
|
|
}
|
|
|
|
sub _link_lists
|
|
{
|
|
# Given two node lists and an edge style, links each node from list
|
|
# one to list two.
|
|
my ($self, $left, $right, $ed, $label, $edge_atr, $edge_bd, $edge_un) = @_;
|
|
|
|
my $graph = $self->{_graph};
|
|
|
|
my $style = $self->_edge_style($ed);
|
|
my $e = $self->{use_class}->{edge};
|
|
|
|
# add edges for all nodes in the left list
|
|
for my $node (@$left)
|
|
{
|
|
for my $node_b (@$right)
|
|
{
|
|
my $edge = $e->new( { style => $style, name => $label } );
|
|
|
|
$graph->add_edge ( $node, $node_b, $edge );
|
|
|
|
# 'string' => [ 'string' ]
|
|
# [ { hash }, 'string' ] => [ { hash }, 'string' ]
|
|
my $e = $edge_atr; $e = [ $edge_atr ] unless ref($e) eq 'ARRAY';
|
|
|
|
for my $a (@$e)
|
|
{
|
|
if (ref $a)
|
|
{
|
|
$edge->set_attributes($a);
|
|
}
|
|
else
|
|
{
|
|
# deferred parsing with the object as param:
|
|
my $out = $self->_parse_attributes($a, $edge);
|
|
return undef if $self->{error};
|
|
$edge->set_attributes($out);
|
|
}
|
|
}
|
|
|
|
# "<--->": bidirectional
|
|
$edge->bidirectional(1) if $edge_bd;
|
|
$edge->undirected(1) if $edge_un;
|
|
}
|
|
}
|
|
|
|
$style;
|
|
}
|
|
|
|
sub _unquote_attribute
|
|
{
|
|
my ($self,$name,$value) = @_;
|
|
|
|
$self->_unquote($value);
|
|
}
|
|
|
|
sub _unquote
|
|
{
|
|
my ($self, $name, $no_collapse) = @_;
|
|
|
|
$name = '' unless defined $name;
|
|
|
|
# unquote special chars
|
|
$name =~ s/\\([\[\(\{\}\]\)#<>\-\.\=])/$1/g;
|
|
|
|
# collapse multiple spaces
|
|
$name =~ s/\s+/ /g unless $no_collapse;
|
|
|
|
$name;
|
|
}
|
|
|
|
sub _add_node
|
|
{
|
|
# add a node to the graph, overidable by subclasses
|
|
my ($self, $graph, $name) = @_;
|
|
|
|
$graph->add_node($name); # add unless exists
|
|
}
|
|
|
|
sub _get_cluster_name
|
|
{
|
|
# create a unique name for an autosplit node
|
|
my ($self, $base_name) = @_;
|
|
|
|
# Try to find a unique cluster name in case some one get's creative and names the
|
|
# last part "-1":
|
|
|
|
# does work without cluster-id?
|
|
if (exists $self->{clusters}->{$base_name})
|
|
{
|
|
my $g = 1;
|
|
while ($g == 1)
|
|
{
|
|
my $base_try = $base_name; $base_try .= '-' . $self->{cluster_id} if $self->{cluster_id};
|
|
last if !exists $self->{clusters}->{$base_try};
|
|
$self->{cluster_id}++;
|
|
}
|
|
$base_name .= '-' . $self->{cluster_id} if $self->{cluster_id}; $self->{cluster_id}++;
|
|
}
|
|
|
|
$self->{clusters}->{$base_name} = undef; # reserve this name
|
|
|
|
$base_name;
|
|
}
|
|
|
|
sub _set_new_basename
|
|
{
|
|
# when encountering something like:
|
|
# [ a | b ]
|
|
# { basename: foo; }
|
|
# the Parser will create two nodes, ab.0 and ab.1, and then later see
|
|
# the "basename: foo". Sowe need to rename the already created nodes
|
|
# due to the changed basename:
|
|
my ($self, $node, $new_basename) = @_;
|
|
|
|
# nothing changes?
|
|
return if $node->{autosplit_basename} eq $new_basename;
|
|
|
|
my $g = $node->{graph};
|
|
|
|
my @parts = @{$node->{autosplit_parts}};
|
|
my $nr = 0;
|
|
for my $part ($node, @parts)
|
|
{
|
|
print STDERR "# Setting new basename $new_basename for node $part->{name}\n"
|
|
if $self->{debug} > 1;
|
|
|
|
$part->{autosplit_basename} = $new_basename;
|
|
$part->set_attribute('basename', $new_basename);
|
|
|
|
# delete it from the list of nodes
|
|
delete $g->{nodes}->{$part->{name}};
|
|
$part->{name} = $new_basename . '.' . $nr; $nr++;
|
|
# and re-insert it with the right name
|
|
$g->{nodes}->{$part->{name}} = $part;
|
|
|
|
# we do not need to care for edges here, as they are stored with refs
|
|
# to the nodes and not the node names itself
|
|
}
|
|
}
|
|
|
|
sub _autosplit_node
|
|
{
|
|
# Takes a node name like "a|b||c" and splits it into "a", "b", and "c".
|
|
# Returns the individual parts.
|
|
my ($self, $graph, $name, $att, $allow_empty) = @_;
|
|
|
|
# Default is to have empty parts. Graphviz sets this to true;
|
|
$allow_empty = 1 unless defined $allow_empty;
|
|
|
|
my @rc;
|
|
my $uc = $self->{use_class};
|
|
my $qr_clean = $self->{_qr_part_clean};
|
|
|
|
# build base name: "A|B |C||D" => "ABCD"
|
|
my $base_name = $name; $base_name =~ s/\s*\|\|?\s*//g;
|
|
|
|
# use user-provided base name
|
|
$base_name = $att->{basename} if exists $att->{basename};
|
|
|
|
# strip trailing/leading spaces on basename
|
|
$base_name =~ s/\s+\z//;
|
|
$base_name =~ s/^\s+//;
|
|
|
|
# first one gets: "ABC", second one "ABC.1" and so on
|
|
$base_name = $self->_get_cluster_name($base_name);
|
|
|
|
print STDERR "# Parser: Autosplitting node with basename '$base_name'\n" if $graph->{debug};
|
|
|
|
my $first_in_row; # for relative placement of new row
|
|
my $x = 0; my $y = 0; my $idx = 0;
|
|
my $remaining = $name; my $sep; my $last_sep = '';
|
|
my $add = 0;
|
|
while ($remaining ne '')
|
|
{
|
|
# XXX TODO: parsing of "\|" and "|" in one node
|
|
$remaining =~ s/^((\\\||[^\|])*)(\|\|?|\z)//;
|
|
my $part = $1 || ' ';
|
|
$sep = $3;
|
|
my $port_name = '';
|
|
|
|
# possible cleanup for this part
|
|
if ($qr_clean)
|
|
{
|
|
$part =~ s/^$qr_clean//; $port_name = $1;
|
|
}
|
|
|
|
# fix [|G|] to have one empty part as last part
|
|
if ($add == 0 && $remaining eq '' && $sep =~ /\|\|?/)
|
|
{
|
|
$add++; # only do it once
|
|
$remaining .= '|'
|
|
}
|
|
|
|
print STDERR "# Parser: Found autosplit part '$part'\n" if $graph->{debug};
|
|
|
|
my $class = $uc->{node};
|
|
if ($allow_empty && $part eq ' ')
|
|
{
|
|
# create an empty node with no border
|
|
$class .= "::Empty";
|
|
}
|
|
elsif ($part =~ /^[ ]{2,}\z/)
|
|
{
|
|
# create an empty node with border
|
|
$part = ' ';
|
|
}
|
|
else
|
|
{
|
|
$part =~ s/^\s+//; # rem spaces at front
|
|
$part =~ s/\s+\z//; # rem spaces at end
|
|
}
|
|
|
|
my $node_name = "$base_name.$idx";
|
|
|
|
if ($graph->{debug})
|
|
{
|
|
my $empty = '';
|
|
$empty = ' empty' if $class ne $self->{use_class}->{node};
|
|
print STDERR "# Parser: Creating$empty autosplit part '$part'\n" if $graph->{debug};
|
|
}
|
|
|
|
# if it doesn't exist, add it, otherwise retrieve node object to $node
|
|
if ($class =~ /::Empty/)
|
|
{
|
|
my $node = $graph->node($node_name);
|
|
if (!defined $node)
|
|
{
|
|
# create node object from the correct class
|
|
$node = $class->new($node_name);
|
|
$graph->add_node($node);
|
|
}
|
|
}
|
|
|
|
my $node = $graph->add_node($node_name);
|
|
$node->{autosplit_label} = $part;
|
|
# remember these two for Graphviz
|
|
$node->{autosplit_portname} = $port_name;
|
|
$node->{autosplit_basename} = $base_name;
|
|
|
|
push @rc, $node;
|
|
if (@rc == 1)
|
|
{
|
|
# for correct as_txt output
|
|
$node->{autosplit} = $name;
|
|
$node->{autosplit} =~ s/\s+\z//; # strip trailing spaces
|
|
$node->{autosplit} =~ s/^\s+//; # strip leading spaces
|
|
$node->{autosplit} =~ s/([^\|])\s+\|/$1 \|/g; # 'foo |' => 'foo |'
|
|
$node->{autosplit} =~ s/\|\s+([^\|])/\| $1/g; # '| foo' => '| foo'
|
|
$node->set_attribute('basename', $att->{basename}) if defined $att->{basename};
|
|
# list of all autosplit parts so as_txt() can find them easily again
|
|
$node->{autosplit_parts} = [ ];
|
|
$first_in_row = $node;
|
|
}
|
|
else
|
|
{
|
|
# second, third etc. get previous as origin
|
|
my ($sx,$sy) = (1,0);
|
|
my $origin = $rc[-2];
|
|
if ($last_sep eq '||')
|
|
{
|
|
($sx,$sy) = (0,1); $origin = $first_in_row;
|
|
$first_in_row = $node;
|
|
}
|
|
$node->relative_to($origin,$sx,$sy);
|
|
push @{$rc[0]->{autosplit_parts}}, $node;
|
|
weaken @{$rc[0]->{autosplit_parts}}[-1];
|
|
|
|
# suppress as_txt output for other parts
|
|
$node->{autosplit} = undef;
|
|
}
|
|
# nec. for border-collapse
|
|
$node->{autosplit_xy} = "$x,$y";
|
|
|
|
$idx++; # next node ID
|
|
$last_sep = $sep;
|
|
$x++;
|
|
# || starts a new row:
|
|
if ($sep eq '||')
|
|
{
|
|
$x = 0; $y++;
|
|
}
|
|
} # end for all parts
|
|
|
|
@rc; # return all created nodes
|
|
}
|
|
|
|
sub _new_node
|
|
{
|
|
# Create a new node unless it doesn't already exist. If the group stack
|
|
# contains entries, the new node appears first in this/these group(s), so
|
|
# add it to these groups. If the newly created node contains "|", we auto
|
|
# split it up into several nodes and cluster these together.
|
|
my ($self, $graph, $name, $group_stack, $att, $stack) = @_;
|
|
|
|
print STDERR "# Parser: new node '$name'\n" if $graph->{debug};
|
|
|
|
$name = $self->_unquote($name, 'no_collapse');
|
|
|
|
my $autosplit;
|
|
my $uc = $self->{use_class};
|
|
|
|
my @rc = ();
|
|
|
|
if ($name =~ /^\s*\z/)
|
|
{
|
|
print STDERR "# Parser: Creating anon node\n" if $graph->{debug};
|
|
# create a new anon node and add it to the graph
|
|
my $class = $uc->{node} . '::Anon';
|
|
my $node = $class->new();
|
|
@rc = ( $graph->add_node($node) );
|
|
}
|
|
# nodes to be autosplit will be done in a sep. pass for Graphviz
|
|
elsif ((ref($self) eq 'Graph::Easy::Parser') && $name =~ /[^\\]\|/)
|
|
{
|
|
$autosplit = 1;
|
|
@rc = $self->_autosplit_node($graph, $name, $att);
|
|
}
|
|
else
|
|
{
|
|
# strip trailing and leading spaces
|
|
$name =~ s/\s+\z//;
|
|
$name =~ s/^\s+//;
|
|
|
|
# collapse multiple spaces
|
|
$name =~ s/\s+/ /g;
|
|
|
|
# unquote \|
|
|
$name =~ s/\\\|/\|/g;
|
|
|
|
if ($self->{debug})
|
|
{
|
|
if (!$graph->node($name))
|
|
{
|
|
print STDERR "# Parser: Creating normal node from name '$name'.\n";
|
|
}
|
|
else
|
|
{
|
|
print STDERR "# Parser: Found node '$name' already in graph.\n";
|
|
}
|
|
}
|
|
@rc = ( $self->_add_node($graph, $name) ); # add to graph, unless exists
|
|
}
|
|
|
|
$self->parse_error(5) if exists $att->{basename} && !$autosplit;
|
|
|
|
my $b = $att->{basename};
|
|
delete $att->{basename};
|
|
|
|
# on a node list "[A],[B] { ... }" set attributes on all nodes
|
|
# encountered so far, too:
|
|
if (defined $stack)
|
|
{
|
|
for my $node (@$stack)
|
|
{
|
|
$node->set_attributes ($att, 0);
|
|
}
|
|
}
|
|
my $index = 0;
|
|
my $group = $self->{group_stack}->[-1];
|
|
|
|
for my $node (@rc)
|
|
{
|
|
$node->add_to_group($group) if $group;
|
|
$node->set_attributes ($att, $index);
|
|
$index++;
|
|
}
|
|
|
|
$att->{basename} = $b if defined $b;
|
|
|
|
# return list of created nodes (usually one, but more for "A|B")
|
|
@rc;
|
|
}
|
|
|
|
sub _match_comma
|
|
{
|
|
# return a regexp that matches something like " , " like in:
|
|
# "[ Bonn ], [ Berlin ] => [ Hamburg ]"
|
|
qr/\s*,\s*/;
|
|
}
|
|
|
|
sub _match_comment
|
|
{
|
|
# match the start of a comment
|
|
qr/(^|[^\\])#/;
|
|
}
|
|
|
|
sub _match_commented_line
|
|
{
|
|
# match empty lines or a completely commented out line
|
|
qr/^\s*(#|\z)/;
|
|
}
|
|
|
|
sub _match_attributes
|
|
{
|
|
# return a regexp that matches something like " { color: red; }" and returns
|
|
# the inner text without the {}
|
|
qr/\s*\{\s*([^\}]+?)\s*\}/;
|
|
}
|
|
|
|
sub _match_optional_attributes
|
|
{
|
|
# return a regexp that matches something like " { color: red; }" and returns
|
|
# the inner text with the {}
|
|
qr/(\s*\{[^\}]+?\})?/;
|
|
}
|
|
|
|
sub _match_node
|
|
{
|
|
# return a regexp that matches something like " [ bonn ]" and returns
|
|
# the inner text without the [] (might leave some spaces)
|
|
|
|
qr/\s*\[ # '[' start of the node
|
|
(
|
|
(?: # non-capturing group
|
|
\\. # either '\]' or '\N' etc.
|
|
| # or
|
|
[^\]\\] # not ']' and not '\'
|
|
)* # 0 times for '[]'
|
|
)
|
|
\]/x; # followed by ']'
|
|
}
|
|
|
|
sub _match_class_selector
|
|
{
|
|
my $class = qr/(?:\.\w+|graph|(?:edge|group|node)(?:\.\w+)?)/;
|
|
qr/($class(?:\s*,\s*$class)*)/;
|
|
}
|
|
|
|
sub _match_single_attribute
|
|
{
|
|
qr/\s*([^:]+?)\s*:\s*("(?:\\"|[^"])+"|(?:\\;|[^;])+?)(?:\s*;\s*|\s*\z)/; # "name: value"
|
|
}
|
|
|
|
sub _match_group_start
|
|
{
|
|
# Return a regexp that matches something like " ( group [" and returns
|
|
# the text between "(" and "[". Also matches empty groups like "( group )"
|
|
# or even "()":
|
|
qr/\s*\(\s*([^\[\)\(]*?)\s*([\[\)\(])/;
|
|
}
|
|
|
|
sub _match_group_end
|
|
{
|
|
# return a regexp that matches something like " )".
|
|
qr/\s*\)\s*/;
|
|
}
|
|
|
|
sub _match_edge
|
|
{
|
|
# Matches all possible edge variants like:
|
|
# -->, ---->, ==> etc
|
|
# <-->, <---->, <==>, <..> etc
|
|
# <-- label -->, <.- label .-> etc
|
|
# -- label -->, .- label .-> etc
|
|
|
|
# "- " must come before "-"!
|
|
# likewise, "..-" must come before ".-" must come before "."
|
|
|
|
# XXX TODO: convert the first group into a non-matching group
|
|
|
|
qr/\s*
|
|
( # egde without label ("-->")
|
|
(<?) # optional left "<"
|
|
(=\s|=|-\s|-|\.\.-|\.-|\.|~)+> # pattern (style) of edge
|
|
| # edge with label ("-- label -->")
|
|
(<?) # optional left "<"
|
|
((=\s|=|-\s|-|\.\.-|\.-|\.|~)+) # pattern (style) of edge
|
|
\s+ # followed by at least a space
|
|
((?:\\.|[^>\[\{])*?) # either \\, \[ etc, or not ">", "[", "{"
|
|
(\s+\5)> # a space and pattern before ">"
|
|
|
|
# inserting this needs mucking with all the code that access $5 etc
|
|
# | # undirected edge (without arrows, but with label)
|
|
# ((=\s|=|-\s|-|\.\.-|\.-|\.|~)+) # pattern (style) of edge
|
|
# \s+ # followed by at least a space
|
|
# ((?:\\.|[^>\[\{])*?) # either \\, \[ etc, or not ">", "[", "{"
|
|
# (\s+\10) # a space and pattern
|
|
|
|
| # undirected edge (without arrows and label)
|
|
(\.\.-|\.-)+ # pattern (style) of edge (at least once)
|
|
|
|
|
(=\s|=|-\s|-|\.|~){2,} # these at least two times
|
|
)
|
|
/x;
|
|
}
|
|
|
|
sub _clean_attributes
|
|
{
|
|
my ($self,$text) = @_;
|
|
|
|
$text =~ s/^\s*\{\s*//; # remove left-over "{" and spaces
|
|
$text =~ s/\s*\}\s*\z//; # remove left-over "}" and spaces
|
|
|
|
$text;
|
|
}
|
|
|
|
sub _parse_attributes
|
|
{
|
|
# Takes a text like "attribute: value; attribute2 : value2;" and
|
|
# returns a hash with the attributes. $class defaults to 'node'.
|
|
# In list context, also returns a flag that is maxlevel-1 when one
|
|
# of the attributes was a multiple one (aka 2 for "red|green", 1 for "red");
|
|
my ($self, $text, $object, $no_multiples) = @_;
|
|
|
|
my $class = $object;
|
|
$class = $object->{class} if ref($object);
|
|
$class = 'node' unless defined $class;
|
|
$class =~ s/\..*//; # remove subclass
|
|
|
|
my $out;
|
|
my $att = {};
|
|
my $multiples = 0;
|
|
|
|
$text = $self->_clean_attributes($text);
|
|
my $qr_att = $self->{_match_single_attribute};
|
|
my $qr_cmt; $qr_cmt = $self->_match_multi_line_comment()
|
|
if $self->can('_match_multi_line_comment');
|
|
my $qr_satt; $qr_satt = $self->_match_special_attribute()
|
|
if $self->can('_match_special_attribute');
|
|
|
|
return {} if $text =~ /^\s*\z/;
|
|
|
|
print STDERR "attr parsing: matching\n '$text'\n against $qr_att\n" if $self->{debug} > 3;
|
|
|
|
while ($text ne '')
|
|
{
|
|
print STDERR "attr parsing: matching '$text'\n" if $self->{debug} > 3;
|
|
|
|
# remove a possible comment
|
|
$text =~ s/^$qr_cmt//g if $qr_cmt;
|
|
|
|
# if the last part was a comment, we end up with an empty text here:
|
|
last if $text =~ /^\s*\z/;
|
|
|
|
# match and remove "name: value"
|
|
my $done = ($text =~ s/^$qr_att//) || 0;
|
|
|
|
# match and remove "name" if "name: value;" didn't match
|
|
$done++ if $done == 0 && $qr_satt && ($text =~ s/^$qr_satt//);
|
|
|
|
return $self->error ("Error in attribute: '$text' doesn't look valid to me.")
|
|
if $done == 0;
|
|
|
|
my $name = $1;
|
|
my $v = $2; $v = '' unless defined $v; # for special attributes w/o value
|
|
|
|
# unquote and store
|
|
$out->{$name} = $self->_unquote_attribute($name,$v);
|
|
}
|
|
|
|
if ($self->{debug} && $self->{debug} > 1)
|
|
{
|
|
require Data::Dumper;
|
|
print STDERR "# ", join (" ", caller),"\n";
|
|
print STDERR "# Parsed attributes into:\n", Data::Dumper::Dumper($out),"\n";
|
|
}
|
|
# possible remap attributes (for parsing Graphviz)
|
|
$out = $self->_remap_attributes($out, $object) if $self->can('_remap_attributes');
|
|
|
|
my $g = $self->{_graph};
|
|
# check for being valid and finally create hash with name => value pairs
|
|
for my $name (sort keys %$out)
|
|
{
|
|
my ($rc, $newname, $v) = $g->validate_attribute($name,$out->{$name},$class,$no_multiples);
|
|
|
|
$self->error($g->{error}) if defined $rc;
|
|
|
|
$multiples = scalar @$v if ref($v) eq 'ARRAY';
|
|
|
|
$att->{$newname} = $v if defined $v; # undef => ignore attribute
|
|
}
|
|
|
|
return $att unless wantarray;
|
|
|
|
($att, $multiples || 1);
|
|
}
|
|
|
|
sub parse_error
|
|
{
|
|
# take a msg number, plus params, and throws an exception
|
|
my $self = shift;
|
|
my $msg_nr = shift;
|
|
|
|
# XXX TODO: should really use the msg nr mapping
|
|
my $msg = "Found unexpected group end"; # 0
|
|
$msg = "Error in attribute: '##param2##' is not a valid attribute for a ##param3##" # 1
|
|
if $msg_nr == 1;
|
|
$msg = "Error in attribute: '##param1##' is not a valid ##param2## for a ##param3##"
|
|
if $msg_nr == 2; # 2
|
|
$msg = "Error: Found attributes, but expected group or node start"
|
|
if $msg_nr == 3; # 3
|
|
$msg = "Error in attribute: multi-attribute '##param1##' not allowed here"
|
|
if $msg_nr == 4; # 4
|
|
$msg = "Error in attribute: basename not allowed for non-autosplit nodes"
|
|
if $msg_nr == 5; # 5
|
|
# for graphviz parsing
|
|
$msg = "Error: Already seen graph start"
|
|
if $msg_nr == 6; # 6
|
|
$msg = "Error: Expected '}', but found file end"
|
|
if $msg_nr == 7; # 7
|
|
|
|
my $i = 1;
|
|
foreach my $p (@_)
|
|
{
|
|
$msg =~ s/##param$i##/$p/g; $i++;
|
|
}
|
|
|
|
$self->error($msg . ' at line ' . $self->{line_nr});
|
|
}
|
|
|
|
sub _parser_cleanup
|
|
{
|
|
# After initial parsing, do a cleanup pass.
|
|
my ($self) = @_;
|
|
|
|
my $g = $self->{_graph};
|
|
|
|
for my $n (ord_values ( $g->{nodes} ))
|
|
{
|
|
next if $n->{autosplit};
|
|
$self->warn("Node '" . $self->_quote($n->{name}) . "' has an offset but no origin")
|
|
if (($n->attribute('offset') ne '0,0') && $n->attribute('origin') eq '');
|
|
}
|
|
|
|
$self;
|
|
}
|
|
|
|
sub _quote
|
|
{
|
|
# make a node name safe for error message output
|
|
my ($self,$n) = @_;
|
|
|
|
$n =~ s/'/\\'/g;
|
|
|
|
$n;
|
|
}
|
|
|
|
1;
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
Graph::Easy::Parser - Parse Graph::Easy from textual description
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
# creating a graph from a textual description
|
|
use Graph::Easy::Parser;
|
|
my $parser = Graph::Easy::Parser->new();
|
|
|
|
my $graph = $parser->from_text(
|
|
'[ Bonn ] => [ Berlin ]'.
|
|
'[ Berlin ] => [ Rostock ]'.
|
|
);
|
|
print $graph->as_ascii();
|
|
|
|
print $parser->from_file('mygraph.txt')->as_ascii();
|
|
|
|
# Also works automatically on graphviz code:
|
|
print Graph::Easy::Parser->from_file('mygraph.dot')->as_ascii();
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
C<Graph::Easy::Parser> lets you parse simple textual descriptions
|
|
of graphs, and constructs a C<Graph::Easy> object from them.
|
|
|
|
The resulting object can than be used to layout and output the graph.
|
|
|
|
=head2 Input
|
|
|
|
The input consists of text describing the graph, encoded in UTF-8.
|
|
|
|
Example:
|
|
|
|
[ Bonn ] --> [ Berlin ]
|
|
[ Frankfurt ] <=> [ Dresden ]
|
|
[ Bonn ] --> [ Frankfurt ]
|
|
[ Bonn ] = > [ Frankfurt ]
|
|
|
|
=head3 Graphviz
|
|
|
|
In addition there is a bit of magic that detects graphviz code, so
|
|
input of the following form will also work:
|
|
|
|
digraph Graph1 {
|
|
"Bonn" -> "Berlin"
|
|
}
|
|
|
|
Note that the magic detection only works for B<named> graphs or graph
|
|
with "digraph" at their start, so the following will not be detected as
|
|
graphviz code because it looks exactly like valid Graph::Easy code
|
|
at the start:
|
|
|
|
graph {
|
|
"Bonn" -> "Berlin"
|
|
}
|
|
|
|
See L<Graph::Easy::Parser::Graphviz> for more information about parsing
|
|
graphs in the DOT language.
|
|
|
|
=head3 VCG
|
|
|
|
In addition there is a bit of magic that detects VCG code, so
|
|
input of the following form will also work:
|
|
|
|
graph: {
|
|
node: { title: Bonn; }
|
|
node: { title: Berlin; }
|
|
edge: { sourcename: Bonn; targetname: Berlin; }
|
|
}
|
|
|
|
See L<Graph::Easy::Parser::VCG> for more information about parsing
|
|
graphs in the VCG language.
|
|
|
|
=head2 Input Syntax
|
|
|
|
This is a B<very> brief description of the syntax for the Graph::Easy
|
|
language, for a full specification, please see L<Graph::Easy::Manual>.
|
|
|
|
=over 2
|
|
|
|
=item nodes
|
|
|
|
Nodes are rendered (or "quoted", if you wish) with enclosing square brackets:
|
|
|
|
[ Single node ]
|
|
[ Node A ] --> [ Node B ]
|
|
|
|
Anonymous nodes do not have a name and cannot be referred to again:
|
|
|
|
[ ] -> [ Bonn ] -> [ ]
|
|
|
|
This creates three nodes, two of them anonymous.
|
|
|
|
=item edges
|
|
|
|
The edges between the nodes can have the following styles:
|
|
|
|
-> solid
|
|
=> double
|
|
.> dotted
|
|
~> wave
|
|
|
|
- > dashed
|
|
.-> dot-dash
|
|
..-> dot-dot-dash
|
|
= > double-dash
|
|
|
|
There are also the styles C<bold>, C<wide> and C<broad>. Unlike the others,
|
|
these can only be set via the (optional) edge attributes:
|
|
|
|
[ AB ] --> { style: bold; } [ ABC ]
|
|
|
|
You can repeat each of the style-patterns as much as you like:
|
|
|
|
--->
|
|
==>
|
|
=>
|
|
~~~~~>
|
|
..-..-..->
|
|
|
|
Note that in patterns longer than one character, the entire
|
|
pattern must be repeated e.g. all characters of the pattern must be
|
|
present. Thus:
|
|
|
|
..-..-..-> # valid dot-dot-dash
|
|
..-..-..> # invalid!
|
|
|
|
.-.-.-> # valid dot-dash
|
|
.-.-> # invalid!
|
|
|
|
In addition to the styles, the following two directions are possible:
|
|
|
|
-- edge without arrow heads
|
|
--> arrow at target node (end point)
|
|
<--> arrow on both the source and target node
|
|
(end and start point)
|
|
|
|
Of course you can combine all directions with all styles. However,
|
|
note that edges without arrows cannot use the shortcuts for styles:
|
|
|
|
--- # valid
|
|
.-.- # valid
|
|
.- # invalid!
|
|
- # invalid!
|
|
~ # invalid!
|
|
|
|
Just remember to use at least two repititions of the full pattern
|
|
for arrow-less edges.
|
|
|
|
You can also give edges a label, either by inlining it into the style,
|
|
or by setting it via the attributes:
|
|
|
|
[ AB ] --> { style: bold; label: foo; } [ ABC ]
|
|
|
|
-- foo -->
|
|
... baz ...>
|
|
|
|
-- solid -->
|
|
== double ==>
|
|
.. dotted ..>
|
|
~~ wave ~~>
|
|
|
|
- dashed - >
|
|
= double-dash = >
|
|
.- dot-dash .->
|
|
..- dot-dot-dash ..->
|
|
|
|
Note that the two patterns on the left and right of the label must be
|
|
the same, and that there is a space between the left pattern and the
|
|
label, as well as the label and the right pattern.
|
|
|
|
You may use inline label only with edges that have an arrow. Thus:
|
|
|
|
<-- label --> # valid
|
|
-- label --> # valid
|
|
|
|
-- label -- # invalid!
|
|
|
|
To use a label with an edge without arrow heads, use the attributes:
|
|
|
|
[ AB ] -- { label: edgelabel; } [ CD ]
|
|
|
|
=item groups
|
|
|
|
Round brackets are used to group nodes together:
|
|
|
|
( Cities:
|
|
|
|
[ Bonn ] -> [ Berlin ]
|
|
)
|
|
|
|
Anonymous groups do not have a name and cannot be referred to again:
|
|
|
|
( [ Bonn ] ) -> [ Berlin ]
|
|
|
|
This creates an anonymous group with the node C<Bonn> in it, and
|
|
links it to the node C<Berlin>.
|
|
|
|
=back
|
|
|
|
Please see L<Graph::Easy::Manual> for a full description of the syntax rules.
|
|
|
|
=head2 Output
|
|
|
|
The output will be a L<Graph::Easy|Graph::Easy> object (unless overridden
|
|
with C<use_class()>), see the documentation for Graph::Easy what you can do
|
|
with it.
|
|
|
|
=head1 EXAMPLES
|
|
|
|
See L<Graph::Easy> for an extensive list of examples.
|
|
|
|
=head1 METHODS
|
|
|
|
C<Graph::Easy::Parser> supports the following methods:
|
|
|
|
=head2 new()
|
|
|
|
use Graph::Easy::Parser;
|
|
my $parser = Graph::Easy::Parser->new();
|
|
|
|
Creates a new parser object. The valid parameters are:
|
|
|
|
debug
|
|
fatal_errors
|
|
|
|
The first will enable debug output to STDERR:
|
|
|
|
my $parser = Graph::Easy::Parser->new( debug => 1 );
|
|
$parser->from_text('[A] -> [ B ]');
|
|
|
|
Setting C<fatal_errors> to 0 will make parsing errors not die, but
|
|
just set an error string, which can be retrieved with L<error()>.
|
|
|
|
my $parser = Graph::Easy::Parser->new( fatal_errors => 0 );
|
|
$parser->from_text(' foo ' );
|
|
print $parser->error();
|
|
|
|
See also L<catch_messages()> for how to catch errors and warnings.
|
|
|
|
=head2 reset()
|
|
|
|
$parser->reset();
|
|
|
|
Reset the status of the parser, clear errors etc. Automatically called
|
|
when you call any of the C<from_XXX()> methods below.
|
|
|
|
=head2 use_class()
|
|
|
|
$parser->use_class('node', 'Graph::Easy::MyNode');
|
|
|
|
Override the class to be used to constructs objects while parsing. The
|
|
first parameter can be one of the following:
|
|
|
|
node
|
|
edge
|
|
graph
|
|
group
|
|
|
|
The second parameter should be a class that is a subclass of the
|
|
appropriate base class:
|
|
|
|
package Graph::Easy::MyNode;
|
|
|
|
use base qw/Graph::Easy::Node/;
|
|
|
|
# override here methods for your node class
|
|
|
|
######################################################
|
|
# when overriding nodes, we also need ::Anon
|
|
|
|
package Graph::Easy::MyNode::Anon;
|
|
|
|
use base qw/Graph::Easy::MyNode/;
|
|
use base qw/Graph::Easy::Node::Anon/;
|
|
|
|
######################################################
|
|
# and :::Empty
|
|
|
|
package Graph::Easy::MyNode::Empty;
|
|
|
|
use base qw/Graph::Easy::MyNode/;
|
|
|
|
######################################################
|
|
package main;
|
|
|
|
use Graph::Easy::Parser;
|
|
use Graph::Easy;
|
|
|
|
use Graph::Easy::MyNode;
|
|
use Graph::Easy::MyNode::Anon;
|
|
use Graph::Easy::MyNode::Empty;
|
|
|
|
my $parser = Graph::Easy::Parser;
|
|
|
|
$parser->use_class('node', 'Graph::Easy::MyNode');
|
|
|
|
my $graph = $parser->from_text(...);
|
|
|
|
The object C<$graph> will now contain nodes that are of your
|
|
custom class instead of plain C<Graph::Easy::Node>.
|
|
|
|
When overriding nodes, you also should provide subclasses
|
|
for C<Graph::Easy::Node::Anon> and C<Graph::Easy::Node::Empty>,
|
|
and make these subclasses of your custom node class as shown
|
|
above. For edges, groups and graphs, you need just one subclass.
|
|
|
|
=head2 from_text()
|
|
|
|
my $graph = $parser->from_text( $text );
|
|
|
|
Create a L<Graph::Easy|Graph::Easy> object from the textual description in C<$text>.
|
|
|
|
Returns undef for error, you can find out what the error was
|
|
with L<error()>.
|
|
|
|
This method will reset any previous error, and thus the C<$parser> object
|
|
can be re-used to parse different texts by just calling C<from_text()>
|
|
multiple times.
|
|
|
|
=head2 from_file()
|
|
|
|
my $graph = $parser->from_file( $filename );
|
|
my $graph = Graph::Easy::Parser->from_file( $filename );
|
|
|
|
Creates a L<Graph::Easy|Graph::Easy> object from the textual description in the file
|
|
C<$filename>.
|
|
|
|
The second calling style will create a temporary C<Graph::Easy::Parser> object,
|
|
parse the file and return the resulting C<Graph::Easy> object.
|
|
|
|
Returns undef for error, you can find out what the error was
|
|
with L<error()> when using the first calling style.
|
|
|
|
=head2 error()
|
|
|
|
my $error = $parser->error();
|
|
|
|
Returns the last error, or the empty string if no error occurred.
|
|
|
|
If you want to catch warnings from the parser, enable catching
|
|
of warnings or errors:
|
|
|
|
$parser->catch_messages(1);
|
|
|
|
# Or individually:
|
|
# $parser->catch_warnings(1);
|
|
# $parser->catch_errors(1);
|
|
|
|
# something which warns or throws an error:
|
|
...
|
|
|
|
if ($parser->error())
|
|
{
|
|
my @errors = $parser->errors();
|
|
}
|
|
if ($parser->warning())
|
|
{
|
|
my @warnings = $parser->warnings();
|
|
}
|
|
|
|
See L<Graph::Easy::Base> for more details on error/warning message capture.
|
|
|
|
=head2 parse_error()
|
|
|
|
$parser->parse_error( $msg_nr, @params);
|
|
|
|
Sets an error message from a message number and replaces embedded
|
|
templates like C<##param1##> with the passed parameters.
|
|
|
|
=head2 _parse_attributes()
|
|
|
|
my $attributes = $parser->_parse_attributes( $txt, $class );
|
|
my ($att, $multiples) = $parser->_parse_attributes( $txt, $class );
|
|
|
|
B<Internal usage only>. Takes a text like this:
|
|
|
|
attribute: value; attribute2 : value2;
|
|
|
|
and returns a hash with the attributes.
|
|
|
|
In list context, also returns the max count of multiple attributes, e.g.
|
|
3 when it encounters something like C<< red|green|blue >>. When
|
|
|
|
=head1 EXPORT
|
|
|
|
Exports nothing.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
L<Graph::Easy>. L<Graph::Easy::Parser::Graphviz> and L<Graph::Easy::Parser::VCG>.
|
|
|
|
=head1 AUTHOR
|
|
|
|
Copyright (C) 2004 - 2007 by Tels L<http://bloodgate.com>
|
|
|
|
See the LICENSE file for information.
|
|
|
|
=cut
|