/[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.5 by wakaba, Tue Dec 9 02:41:39 2008 UTC
# Line 1  Line 1 
1  #!/usr/bin/perl  #!/usr/bin/perl
2  use strict;  use strict;
3  use warnings;  use warnings;
 use feature 'state';  
4  use CGI::Carp qw(fatalsToBrowser);  use CGI::Carp qw(fatalsToBrowser);
5    
6    use FindBin;
7    use lib qq[$FindBin::Bin/../lib];
8  use lib q[/home/wakaba/work/manakai2/lib];  use lib q[/home/wakaba/work/manakai2/lib];
9  use Message::CGI::Util qw/percent_decode htescape/;  use Message::CGI::Util qw/htescape/;
10  use Message::CGI::HTTP;  use Encode;
   
 use Regexp::Parser;  
 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' => '(?<!)',  
 };  
11    
12    use Message::CGI::HTTP;
13  my $cgi = Message::CGI::HTTP->new;  my $cgi = Message::CGI::HTTP->new;
14    
15  my $regexp = percent_decode $cgi->get_parameter ('s') // '';  my $regexp = decode 'utf-8', $cgi->get_parameter ('s') // '';
16  $regexp = '(?:)' unless length $regexp;  $regexp = '(?:)' unless length $regexp;
17    my $eregexp = htescape $regexp;
18    
19  my $parser = Regexp::Parser->new;  my $lang = $cgi->get_parameter ('l') // 'perl58';
20    my $class = $lang eq 'js'
21  package Regexp::Parser;      ? 'Regexp::Parser::JavaScript'
22        : 'Regexp::Parser::Perl58';
23    
24    use UNIVERSAL::require;
25    $class->use or die $@;
26    my $parser = $class->new;
27    
28    my @error;
29    $parser->onerror (sub {
30      my %args = @_;
31      my $r = '<li>';
32      if ($args{level} eq 'w') {
33        $r .= '<strong>Warning</strong>: ';
34      } else {
35        $r .= '<strong>Error</strong>: ';
36      }
37    
38    # start of char class range (or maybe just char)    $r .= htescape sprintf $args{type}, @{$args{args}};
   $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);  
         }  
 }  
     }  
39    
40      return if &SIZE_ONLY;    $r .= ': <code>';
41      return $ret;    $r .= htescape substr ${$args{valueref}}, 0, $args{pos_start};
42    });    $r .= '<mark>';
43      $r .= htescape substr ${$args{valueref}},
44          $args{pos_start}, $args{pos_end} - $args{pos_start};
45      $r .= '</mark>';
46      $r .= htescape substr ${$args{valueref}}, $args{pos_end};
47      $r .= '</code></li>';
48    
49  package main;    push @error, $r;
50    });
51    
52  $parser->parse ($regexp);  eval {
53  my $eregexp = htescape $regexp;    $parser->parse ($regexp);
54    };
55    
56  if ($parser->errnum) {  if ($parser->errnum) {
57    binmode STDOUT, ':encoding(utf-8)';    binmode STDOUT, ':encoding(utf-8)';
58    print "Content-Type: text/html; charset=utf-8\n\n";    print "Content-Type: text/html; charset=utf-8\n\n";
59    print q[<!DOCTYPE HTML><html lang=en>    print q[<!DOCTYPE HTML><html lang=en>
60  <title>Regular expression visualizer: $eregexp</title>  <title>Regular expression visualizer: ], $eregexp, q[</title>
61  <link rel="stylesheet" href="/www/style/html/xhtml"/>  <link rel="stylesheet" href="/www/style/html/xhtml"/>
62  </head>  </head>
63  <body>  <body>
# Line 107  if ($parser->errnum) { Line 65  if ($parser->errnum) {
65    
66  <p>Input: <code>], $eregexp, q[</code></p>  <p>Input: <code>], $eregexp, q[</code></p>
67    
68  <p>Error: ], htescape ($parser->errmsg);  <p>Error:
69    <ul>];
70      print join '', @error;
71      print q[</ul>];
72    
73    exit;    exit;
74  }  }
75    
76    require Regexp::Visualize::Simple;
77    my $v = Regexp::Visualize::Simple->new;
78    $v->push_regexp_node ($parser->root);
79    
80  binmode STDOUT, ':encoding(utf-8)';  binmode STDOUT, ':encoding(utf-8)';
81  print "Content-Type: application/xhtml+xml; charset=utf-8\n\n";  print "Content-Type: application/xhtml+xml; charset=utf-8\n\n";
82    
 add_regexp ($parser->root);  
   
83  print q[<html lang="en" xmlns="http://www.w3.org/1999/xhtml">  print q[<html lang="en" xmlns="http://www.w3.org/1999/xhtml">
84  <head><title>Regular expression visualizer: $eregexp</title>  <head><title>Regular expression visualizer: ], $eregexp, q[</title>
85  <link rel="stylesheet" href="/www/style/html/xhtml"/>  <link rel="stylesheet" href="/www/style/html/xhtml"/>
86  </head>  </head>
87  <body>  <body>
# Line 125  print q[<html lang="en" xmlns="http://ww Line 89  print q[<html lang="en" xmlns="http://ww
89    
90  <p>Input: <code>], $eregexp, q[</code></p>];  <p>Input: <code>], $eregexp, q[</code></p>];
91    
92  my @regexp;  if (@error) {
93  while (@regexp) {    print q[<ul>];
94    my $nodes = shift @regexp;    print join '', @error;
95      print q[</ul>];
96    }
97    
98    my $index = get_graph_index ($nodes);  while ($v->has_regexp_node) {
99    print "<section><h2>Regexp #$index</h2>\n\n";    my ($g, $index) = $v->next_graph;
100    
101    my $g = generate_graph ($nodes);    print "<section><h2>Regexp #$index</h2>\n\n";
102    print $g->as_svg;    print $g->as_svg;
   
103    print "</section>\n";    print "</section>\n";
104  }  }
105    
106  print q[</body></html>];  print q[</body></html>];
107    
 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.5
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24