our $VERSION = '2.48';
my %GRAPHVIZ_ARGS = (
edge => {color => 'grey'},
global => {directed => 1},
graph => {rankdir => 'TB'},
node => {color => 'blue', shape => 'oval'},
);
my %STATE2LABEL = (
PLUS => '+',
STAR => '*',
);
my %NODETYPE2ARGS = (
exact => { shape => 'box', color => 'black' },
anyof => { shape => 'box', color => 'red' },
branch => { shape => 'diamond' },
);
my %TYPE2LABEL = (
anyof => sub { "[$_[0]]" },
exact => sub { $_[0] },
open => sub { "START \$$_[0]" },
close => sub { "END \$$_[0]" },
repeat => sub { "REPEAT $_[0]" },
branch => sub { '' },
nothing => sub { 'Match empty string' },
minmod => sub { 'Next operator\nnon-greedy' },
succeed => sub { 'SUCCEED' },
);
my %EDGETYPE2ARGS = (
of => { style => 'dashed' },
cond => { style => 'dashed' },
);
sub maybe_subgraph {
my ($g, $v) = @_;
return unless my @e = grep $g->get_edge_attribute(@$_, 'type'), $g->edges_from($v);
{
attributes => { subgraph => { rank => 'same' } },
nodes => [ $v, map $_->[1], @e ],
};
}
has as_graph => (
is => 'lazy',
required => 0,
);
sub _build_as_graph { to_graph($_[0]->regexp) }
sub to_graph {
my ($regexp) = @_;
my $g = Graph::Directed->new;
run3
[$^X, '-Mre=debug', '-e', q|qr/$ARGV[0]/|, $regexp],
undef,
\my $stdout,
\my $stderr,
;
my (%following, %states, $last_id);
for my $line ( split /\n/, $stderr ) {
next unless my ($id, $state) = $line =~ /(\d+):\s+(.+)$/;
$states{$id} = $state;
$following{$last_id} = $id if $last_id;
$last_id = $id;
}
die 'Error compiling regexp' if !defined $last_id;
my %done;
my @todo = (1);
while (@todo) {
my $id = pop @todo;
next if !$id or $done{$id}++;
my $state = $states{$id} || '';
my $following = $following{$id};
$state =~ s/\s*\((\d+)\)$//;
my $next = $1;
push @todo, $following;
push @todo, $next if $next;
my $match;
if ( ($match) = $state =~ /^EXACTF?L? <(.+)>$/ ) {
$g->set_vertex_attributes($id, { type => 'exact', content => $match });
$g->add_edge($id, $next) if $next != 0;
$done{$following}++ unless $next;
} elsif ( ($match) = $state =~ /^ANYOF\[(.+)\]/ ) {
$g->set_vertex_attributes($id, { type => 'anyof', content => $match });
$g->add_edge($id, $next) if $next != 0;
$done{$following}++ unless $next;
} elsif ( (my $matchtype, $match) = $state =~ /^(OPEN|CLOSE)(\d+)/ ) {
$g->set_vertex_attributes($id, { type => lc $matchtype, content => $match });
$g->add_edge($id, $matchtype eq 'OPEN' ? $following : $next);
} elsif ( $state =~ /^BRANCH/ ) {
my $branch = $next;
my @children;
push @children, $following;
while ($branch && ($states{$branch}||'') =~ /^BRANCH|TAIL/ ) {
$done{$branch}++;
push @children, $following{$branch};
push @todo, $following{$branch};
($branch) = $states{$branch} =~ /(\d+)/;
}
$g->set_vertex_attributes($id, { type => lc $state });
$g->add_edges(map [$id, $_], @children);
} elsif ( my ($repetition) = $state =~ /^(PLUS|STAR)/ ) {
$g->set_vertex_attributes($id, { type => 'repeat', content => $STATE2LABEL{$repetition} });
$g->set_edge_attributes($id, $following, { type => 'of' });
$g->add_edge($id, $next);
} elsif ( my ( $type, $min, $max )
= $state =~ /^CURLY([NMX]?)\[?\d*\]?\s*\{(\d+),(\d+)\}/ )
{
$g->set_vertex_attributes($id, { type => 'repeat', content => "{$min,$max}" });
$g->set_edge_attributes($id, $following, { type => 'of' });
$g->add_edge($id, $next);
} elsif ( $state =~ /^SUCCEED/ ) {
$g->set_vertex_attributes($id, { type => lc $state });
$done{$following}++;
} elsif ( $state =~ /^(UNLESSM|IFMATCH|IFTHEN)/ ) {
$g->set_vertex_attributes($id, { type => lc $state });
$g->set_edge_attributes($id, $following, { type => 'cond' });
$g->add_edge($id, $next);
} else {
$g->set_vertex_attributes($id, { type => lc $state });
$g->add_edge($id, $next) if ($next||0) != 0;
}
}
$g;
}
has graph => (
is => 'lazy',
required => 0,
);
sub _build_graph {
GraphViz2->new(%GRAPHVIZ_ARGS)->from_graph(graphvizify($_[0]->as_graph));
}
has regexp => (
is => 'rw',
required => 0,
);
sub create {
my ($self, %arg) = @_;
$self->regexp($arg{regexp});
$self->graph->from_graph(graphvizify($self->as_graph));
return $self;
}
sub graphvizify {
my ($g) = @_;
my @groups;
for my $v (sort $g->vertices) {
push @groups, maybe_subgraph($g, $v);
my $attrs = $g->get_vertex_attributes($v);
my $type = $attrs->{type};
my $labelmaker = $TYPE2LABEL{$type};
my $label = $labelmaker ? $labelmaker->(GraphViz2::_dor($attrs->{content}, '')) : uc $type;
$g->set_vertex_attribute($v, graphviz => { label => $label, %{$NODETYPE2ARGS{$type}||{}} });
for my $e (sort {$a->[1] cmp $b->[1]} $g->edges_from($v)) {
my $e_attrs = $g->get_edge_attributes(@$e);
my $e_type = $e_attrs->{type};
$g->set_edge_attribute(@$e, graphviz => $EDGETYPE2ARGS{$e_type||''}||{});
}
}
$g->set_graph_attribute(graphviz => { groups => \@groups });
$g;
}
1;