/[suikacvs]/webroot/regexp/visualizer/regexp.cgi
Suika

Diff of /webroot/regexp/visualizer/regexp.cgi

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.2 by wakaba, Sun Dec 7 10:24:21 2008 UTC revision 1.3 by wakaba, Sun Dec 7 11:46:05 2008 UTC
# Line 4  use warnings; Line 4  use warnings;
4  use feature 'state';  use feature 'state';
5  use CGI::Carp qw(fatalsToBrowser);  use CGI::Carp qw(fatalsToBrowser);
6    
7    use FindBin;
8    use lib qq[$FindBin::Bin/../lib];
9  use lib q[/home/wakaba/work/manakai2/lib];  use lib q[/home/wakaba/work/manakai2/lib];
10  use Message::CGI::Util qw/percent_decode htescape/;  use Message::CGI::Util qw/percent_decode htescape/;
11  use Message::CGI::HTTP;  use Message::CGI::HTTP;
12    
13  use Regexp::Parser;  use Regexp::Parser::Perl58;
 use Graph::Easy;  
   
 use Scalar::Util qw/refaddr/;  
   
 my $default_map = {};  
 for (qw/. \C \w \W \s \S \d \D \X \1 \2 \3 \4 \5 \6 \7 \8 \9  
         \A ^ \B \b \G \Z \z $/) {  
   $default_map->{$_} = qq[Perl /$_/];  
 }  
   
 my $assertion_map = {  
     ifmatch => '(?=)',  
     '<ifmatch' => '(?<=)',  
     unlessm => '(?!)',  
     '<unlessm' => '(?<!)',  
 };  
14    
15  my $cgi = Message::CGI::HTTP->new;  my $cgi = Message::CGI::HTTP->new;
16    
17  my $regexp = percent_decode $cgi->get_parameter ('s') // '';  my $regexp = percent_decode $cgi->get_parameter ('s') // '';
18  $regexp = '(?:)' unless length $regexp;  $regexp = '(?:)' unless length $regexp;
19    
20  my $parser = Regexp::Parser->new;  my $parser = Regexp::Parser::Perl58->new;
   
 package Regexp::Parser;  
   
   # start of char class range (or maybe just char)  
   $parser->add_handler('cc' => sub {  
     my ($S) = @_;  
     return if ${&Rx} =~ m{ \G (?= ] | \z ) }xgc;  
     push @{ $S->{next} }, qw< cc >;  
     my ($lhs, $rhs, $before_range);  
     my $ret = \$lhs;  
   
 {  
   if (${&Rx} =~ m{ \G ( \\ ) }xgcs) {  
         my $c = $1;  
         $$ret = $S->$c(1);  
       }  
 elsif (${&Rx} =~ m{ \G \[ ([.=:]) (\^?) (.*?) \1 \] }xgcs) {  
         my ($how, $neg, $name) = ($1, $2, $3);  
         my $posix = "POSIX_$name";  
         if ($S->can($posix)) { $$ret = $S->$posix($neg, $how) }  
         else { $S->error(RPe_BADPOS, "$how$neg$name$how") }  
       }  
       elsif (${&Rx} =~ m{ \G (.) }xgcs) {  
         $$ret = $S->force_object(anyof_char => $1);  
       }  
   
 if ($ret == \$lhs) {  
   if (${&Rx} =~ m{ \G (?= - ) }xgc) {  
   if ($lhs->visual =~ /^(?:\[[:.=]|\\[dDsSwWpP])/) {  
             $S->warn(RPe_FRANGE, $lhs->visual, "");  
             $ret = $lhs;  
             last;  
           }  
           $before_range = &RxPOS++;  
           $ret = \$rhs;  
           redo;  
 }  
         $ret = $lhs;  
       }  
 elsif ($ret == \$rhs) {  
   if ($rhs->visual =~ /^(?:\[[:.=]|\\[dDsSwWpP])/) {  
           $S->warn(RPe_FRANGE, $lhs->visual, $rhs->visual);  
           &RxPOS = $before_range;  
           $ret = $lhs;  
         }  
   elsif ($lhs->data gt $rhs->data) {  
           $S->error(RPe_IRANGE, $lhs->visual, $rhs->visual);  
         }  
         else {  
           $ret = $S->object(anyof_range => $lhs, $rhs);  
         }  
 }  
     }  
21    
22      return if &SIZE_ONLY;  eval {
23      return $ret;    $parser->parse ($regexp);
24    });  };
   
 package main;  
   
 $parser->parse ($regexp);  
25  my $eregexp = htescape $regexp;  my $eregexp = htescape $regexp;
26    
27  if ($parser->errnum) {  if ($parser->errnum) {
# Line 111  if ($parser->errnum) { Line 40  if ($parser->errnum) {
40    exit;    exit;
41  }  }
42    
43    require Regexp::Visualize::Simple;
44    my $v = Regexp::Visualize::Simple->new;
45    $v->push_regexp_node ($parser->root);
46    
47  binmode STDOUT, ':encoding(utf-8)';  binmode STDOUT, ':encoding(utf-8)';
48  print "Content-Type: application/xhtml+xml; charset=utf-8\n\n";  print "Content-Type: application/xhtml+xml; charset=utf-8\n\n";
49    
 add_regexp ($parser->root);  
   
50  print q[<html lang="en" xmlns="http://www.w3.org/1999/xhtml">  print q[<html lang="en" xmlns="http://www.w3.org/1999/xhtml">
51  <head><title>Regular expression visualizer: $eregexp</title>  <head><title>Regular expression visualizer: $eregexp</title>
52  <link rel="stylesheet" href="/www/style/html/xhtml"/>  <link rel="stylesheet" href="/www/style/html/xhtml"/>
# Line 125  print q[<html lang="en" xmlns="http://ww Line 56  print q[<html lang="en" xmlns="http://ww
56    
57  <p>Input: <code>], $eregexp, q[</code></p>];  <p>Input: <code>], $eregexp, q[</code></p>];
58    
59  my @regexp;  while ($v->has_regexp_node) {
60  while (@regexp) {    my ($g, $index) = $v->next_graph;
   my $nodes = shift @regexp;  
61    
   my $index = get_graph_index ($nodes);  
62    print "<section><h2>Regexp #$index</h2>\n\n";    print "<section><h2>Regexp #$index</h2>\n\n";
   
   my $g = generate_graph ($nodes);  
63    print $g->as_svg;    print $g->as_svg;
   
64    print "</section>\n";    print "</section>\n";
65  }  }
66    
67  print q[</body></html>];  print q[</body></html>];
68    
 sub escape_value ($) {  
   my $v = shift;  
   $v =~ s/(\W)/sprintf '\x{%04X}', ord $1/ge;  
   $v;  
 } # escape_value  
   
 sub escape_code ($) {  
   my $v = shift;  
   $v =~ s/([^\x20-\x5B\x5D-\x7E])/sprintf '\x{%04X}', ord $1/ge;  
   $v;  
 } # escape_code  
   
 sub add_regexp ($) {  
   my $nodes = shift;  
   push @regexp, $nodes;  
 } # add_regexp  
   
 sub get_graph_index ($) {  
   state $index;  
   state $next_index ||= 0;  
   
   my $nodes = shift;  
   $index->{$nodes} //= $next_index++;  
   return $index->{$nodes};  
 } # get_graph_index  
   
 sub generate_graph ($$) {  
   my ($root_nodes) = @_;  
   
   my $g = Graph::Easy->new;  
   
   $g->set_attributes ('node.start' => {fill => 'blue', color => 'white'});  
   $g->set_attributes ('node.success' => {fill => 'green', color => 'white'});  
     
   my $start_n = $g->add_node ('START');  
   $start_n->set_attribute (class => 'start');  
   my $success_n = $g->add_node ('SUCCESS');  
   $success_n->set_attribute (class => 'success');  
   
   my ($first_ns, $last_ns, $is_optional) = add_to_graph ($root_nodes => $g);  
   $g->add_edge ($start_n => $_) for @$first_ns;  
   $g->add_edge ($_ => $success_n) for @$last_ns;  
   $g->add_edge ($start_n => $success_n) if $is_optional;  
     
   return $g;  
 } # generate_graph  
   
 sub add_to_graph ($$) {  
   my ($node, $g) = @_;  
   
   my $family = ref $node eq 'ARRAY' ? '' : $node->family;  
   my $type = ref $node eq 'ARRAY' ? '' : $node->type;  
   if ($family eq 'quant') {  
     my ($min, $max) = ($node->min, $node->max);  
     return ([], [], 1) if $max eq '0';  
     my ($first_ns, $last_ns, $is_optional) = add_to_graph ($node->data => $g);  
   
     my $label;  
     if ($max eq '') {  
       if ($min == 0) {  
         $is_optional = 1;  
         $label = '';  
           
       } elsif ($min == 1) {  
         $label = '';  
           
       } else {  
         $label = 'at least ' . ($min - 1);  
           
       }  
     } elsif ($max == 1) {  
       if ($min == 0) {  
         $is_optional = 1;  
           
       } else {  
           
       }  
     } else {  
       $label = 'at most ' . ($max - 1);  
       if ($min == 0) {  
         $is_optional = 1;  
           
   
       } elsif ($min == 1) {  
           
       } else {  
         $label = 'at least ' . ($min - 1) . ', ' . $label;  
   
       }  
     }  
       
     if (@$first_ns != 1 or @$last_ns != 1) {  
       my $n = $g->add_node (refaddr $first_ns);  
       $n->set_attribute (label => '');  
       my $m = $n;  
       unless ($is_optional) {  
         $m = $g->add_node (refaddr $last_ns);  
         $m->set_attribute (label => '');  
       } else {  
         $is_optional = 0;  
       }  
       $g->add_edge ($n => $_) for @$first_ns;  
       $g->add_edge ($_ => $m) for @$last_ns;  
       $first_ns = [$n];  
       $last_ns = [$m];  
     }  
   
     if (defined $label) {  
       my $e = $g->add_edge ($last_ns->[0] => $first_ns->[0]);  
       $e->set_attribute (label => $label);  
     }  
   
     return ($first_ns, $last_ns, $is_optional);  
   } elsif ($type eq 'branch') {  
     my @first_n;  
     my @last_n;  
     my $is_optional = 0;  
     for (@{$node->data}) {  
       my ($f_ns, $l_ns, $is_opt) = add_to_graph ($_ => $g);  
       push @first_n, @$f_ns;  
       push @last_n, @$l_ns;  
       $is_optional |= $is_opt;  
     }  
     return (\@first_n, \@last_n, $is_optional);  
   } elsif ($type eq 'anyof') {  
     if ($node->neg) {  
       my $nodes = Regexp::Parser::branch->new ($node->{rx});  
       $nodes->{data} = $node->data;  
         
       add_regexp ($nodes);  
         
       my $n = $g->add_node (refaddr $nodes);  
       my $label = 'NOT #' . get_graph_index ($nodes);  
       $n->set_attribute (label => $label);  
         
       return ([$n], [$n], 0);        
     } else {  
       my @first_n;  
       my @last_n;  
       for (@{$node->data}) {  
         my ($f_ns, $l_ns) = add_to_graph ($_ => $g);  
         push @first_n, @$f_ns;  
         push @last_n, @$l_ns;  
       }  
       return (\@first_n, \@last_n, 0);  
     }  
   } elsif ($type eq '') {  
     my $prev_ns;  
     my $first_ns;  
     my $is_optional = 1;  
     for (@{$node}) {  
       my ($f_ns, $l_ns, $is_opt) = add_to_graph ($_ => $g);  
       if ($prev_ns) {  
         if (@$prev_ns > 1 and @$f_ns > 1) {  
           my $n = $g->add_node (refaddr $f_ns);  
           $n->set_attribute (label => '');  
           $g->add_edge ($_ => $n) for @$prev_ns;  
           $g->add_edge ($n => $_) for @$f_ns;  
         } else {  
           for my $prev_n (@$prev_ns) {  
             for my $f_n (@$f_ns) {  
               $g->add_edge ($prev_n => $f_n);  
             }  
           }  
         }  
         if ($is_optional) {  
           push @$first_ns, @$f_ns;  
         }  
         if ($is_opt) {  
           push @$prev_ns, @$l_ns;  
         } else {  
           $prev_ns = $l_ns if @$l_ns;  
         }  
       } else {  
         $first_ns = $f_ns;  
         $prev_ns = $l_ns if @$l_ns;  
       }  
       $is_optional &= $is_opt;  
     }  
     return ($first_ns || [], $prev_ns || [], $is_optional);  
   } elsif ($family eq 'group' or $family eq 'open' or $type eq 'suspend') {  
     ## TODO: (?:) vs () vs (?>), (?:)->on, (?:)->off  
     my ($f_ns, $l_ns, $is_opt) = add_to_graph ($node->data => $g);  
     return ($f_ns, $l_ns, $is_opt);  
   } elsif ($type eq 'ifthen') {  
     my $nodes = $node->data;  
       
     my $groupp = $nodes->[0];  
     my $label = $groupp ? '(?' . $groupp->visual . ')' : '';  
     my $n = $g->add_node (refaddr $groupp);  
     $n->set_attribute (label => $label);  
   
     my $l = $g->add_node (refaddr $nodes);  
     $l->set_attribute (label => '');  
       
     my $branch = $nodes->[1];  
     my $branches = $branch ? $branch->data : [];  
       
     my $true = $branches->[0];  
     if ($true) {  
       my ($f_ns, $l_ns, $is_opt) = add_to_graph ($true => $g);  
       $g->add_edge ($n => $_)->set_attribute (label => 'true') for @$f_ns;  
       $g->add_edge ($_ => $l) for @$l_ns;  
       $g->add_edge ($n => $l)->set_attribute (label => 'true') if $is_opt;  
     }  
   
     my $false = $branches->[1];  
     if ($false) {  
       my ($f_ns, $l_ns, $is_opt) = add_to_graph ($false => $g);  
       $g->add_edge ($n => $_)->set_attribute (label => 'false') for @$f_ns;  
       $g->add_edge ($_ => $l) for @$l_ns;  
       $g->add_edge ($n => $l)->set_attribute (label => 'false') if $is_opt;  
     }  
       
     return ([$n], [$l], 0);  
   } elsif ($type eq 'eval' or $type eq 'logical') {  
     my $n = $g->add_node (refaddr $node);  
     my $label = $type eq 'eval' ? '(?{})' : '(??{})';  
     $label .= ' ' . escape_code $node->data;  
     $n->set_attribute (label => $label);  
     return ([$n], [$n], 0);  
   } elsif ($family eq 'assertion') {  
     my $nodes = $node->data;  
     add_regexp ($nodes);  
       
     my $n = $g->add_node (refaddr $nodes);  
     $type = '<' . $type if $node->dir < 0;  
     my $label = $assertion_map->{$type} // $type;  
     $label .= ' #' . get_graph_index ($nodes);  
     $n->set_attribute (label => $label);  
       
     return ([$n], [$n], 0);  
   } elsif ($family eq 'anyof_class') {  
     my $data = $node->data;  
     my $label;  
     if ($data eq 'POSIX') {  
       my $how = ${$node->{how}};  
       if ($how eq ':') {  
         $label = 'POSIX ' . $node->{type};  
         $label = 'NOT ' . $label if $node->neg;  
       } else {  
         $label = $how . $node->neg . $node->{type} . $how;  
       }  
     } else {  
       my $data_family = $data->family;  
       if ($data_family eq 'prop') {  
         $label = 'property ' . $node->type;  
         $label = 'NOT ' . $label if $node->neg;  
       } elsif ($data_family eq 'space') {  
         $label = $data->neg ? 'Perl /\S/' : 'Perl /\s/';  
       } elsif ($data_family eq 'alnum') {  
         $label = $data->neg ? 'Perl /\W/' : 'Perl /\w/';  
       } elsif ($data_family eq 'digit') {  
         $label = $data->neg ? 'Perl /\D/' : 'Perl /\d/';  
       } else {  
         $label = $data->visual;  
       }  
     }  
     
     my $n = $g->add_node (refaddr $node);  
     $n->set_attribute (label => $label);  
       
     return ([$n] => [$n]);  
   } elsif ($family eq 'exact' or $type eq 'anyof_char') {  
     my $n = $g->add_node (refaddr $node);  
   
     my $label = escape_value $node->data;  
     $n->set_attribute (label => qq[ "$label" ]);  
   
     return ([$n] => [$n]);  
   } elsif ($family eq 'flags') {  
     ## TODO: scope  
     my $n = $g->add_node (refaddr $node);  
   
     my $label = $node->visual;  
     $n->set_attribute (label => $label);  
   
     return ([$n] => [$n], 0);  
   } elsif ($family eq 'minmod') {  
     my $nodes = $node->data;  
     add_regexp ($nodes);  
   
     my $n = $g->add_node (refaddr $nodes);  
     my $label = 'non-greedy #' . get_graph_index ($nodes);  
     $n->set_attribute (label => $label);  
   
     return ([$n], [$n], 0);  
   } elsif ($family eq 'anyof_range') {  
     my $n = $g->add_node (refaddr $node);  
   
     my $start = escape_value $node->data->[0]->data;  
     my $end = escape_value $node->data->[1]->data;  
     my $label = qq[ one of "$start" .. "$end" ];  
     $n->set_attribute (label => $label);  
   
     return ([$n] => [$n], 0);  
   } else {  
     # anyof_char  
     # anyof_range  
   
     my $n = $g->add_node (refaddr $node);  
       
     my $label = $node->visual;  
     $label = $default_map->{$label} // escape_value $label;  
     $label .= ' (' . $type . ')';  
     $n->set_attribute (label => $label);  
       
     return ([$n] => [$n], 0);  
   }  
 } # add_to_graph  
   
Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24