/[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.1 by wakaba, Sun Dec 7 09:48:35 2008 UTC revision 1.6 by wakaba, Sun Mar 8 15:14:52 2009 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/;  use Message::CGI::Util qw/htescape/;
10    use Encode;
11    
12  use Regexp::Parser;  use Message::CGI::HTTP;
13  use Graph::Easy;  my $cgi = Message::CGI::HTTP->new;
14    
15  use Scalar::Util qw/refaddr/;  my $regexp = decode 'utf-8', $cgi->get_parameter ('s') // '';
16    $regexp = '(?:)' unless length $regexp;
17    my $eregexp = htescape $regexp;
18    
19  my $default_map = {};  my $lang = $cgi->get_parameter ('l') // 'perl58';
20  for (qw/. \C \w \W \s \S \d \D \X \1 \2 \3 \4 \5 \6 \7 \8 \9  my $class = $lang eq 'js'
21          \A ^ \B \b \G \Z \z $/) {      ? 'Regexp::Parser::JavaScript'
22    $default_map->{$_} = qq[Perl /$_/];      : 'Regexp::Parser::Perl58';
23  }  
24    use UNIVERSAL::require;
25    $class->use or die $@;
26    my $parser = $class->new;
27    
28    my $footer = q[
29      <footer>
30      [<a href="input">Input</a>]
31      [<a href="../doc/readme">Source</a>]
32      </footer>
33    ];
34    
35    my @error;
36    $parser->onerror (sub {
37      my %args = @_;
38      my $r = '<li>';
39      if ($args{level} eq 'w') {
40        $r .= '<strong>Warning</strong>: ';
41      } else {
42        $r .= '<strong>Error</strong>: ';
43      }
44    
45      $r .= htescape sprintf $args{type}, @{$args{args}};
46    
47      $r .= ': <code>';
48      $r .= htescape substr ${$args{valueref}}, 0, $args{pos_start};
49      $r .= '<mark>';
50      $r .= htescape substr ${$args{valueref}},
51          $args{pos_start}, $args{pos_end} - $args{pos_start};
52      $r .= '</mark>';
53      $r .= htescape substr ${$args{valueref}}, $args{pos_end};
54      $r .= '</code></li>';
55    
56  my $assertion_map = {    push @error, $r;
57      ifmatch => '(?=)',  });
58      '<ifmatch' => '(?<=)',  
59      unlessm => '(?!)',  eval {
60      '<unlessm' => '(?<!)',    $parser->parse ($regexp);
61  };  };
62    
63  my $regexp = percent_decode $ENV{QUERY_STRING};  if ($parser->errnum) {
64  $regexp = '(?:)' unless length $regexp;    binmode STDOUT, ':encoding(utf-8)';
65      print "Content-Type: text/html; charset=utf-8\n\n";
66      print q[<!DOCTYPE HTML><html lang=en>
67    <title>Regular expression visualizer: ], $eregexp, q[</title>
68    <link rel="stylesheet" href="/www/style/html/xhtml">
69    
70  my $parser = Regexp::Parser->new;  <h1>Regular expression visualizer</h1>
71    
72  package Regexp::Parser;  <p>Input: <code>], $eregexp, q[</code></p>
73    
74    # start of char class range (or maybe just char)  <p>Error:
75    $parser->add_handler('cc' => sub {  <ul>];
76      my ($S) = @_;    print join '', @error;
77      return if ${&Rx} =~ m{ \G (?= ] | \z ) }xgc;    print q[</ul>];
     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);  
         }  
 }  
     }  
78    
79      return if &SIZE_ONLY;    print $footer;
     return $ret;  
   });  
80    
81  package main;    exit;
82    }
83    
84  $parser->parse ($regexp);  require Regexp::Visualize::Simple;
85    my $v = Regexp::Visualize::Simple->new;
86    $v->push_regexp_node ($parser->root);
87    
88  binmode STDOUT, ':encoding(utf-8)';  binmode STDOUT, ':encoding(utf-8)';
89  print "Content-Type: application/xhtml+xml; charset=utf-8\n\n";  print "Content-Type: application/xhtml+xml; charset=utf-8\n\n";
90    
91  print $parser->errnum, $parser->errmsg;  print q[<html lang="en" xmlns="http://www.w3.org/1999/xhtml">
92    <head><title>Regular expression visualizer: ], $eregexp, q[</title>
93  add_regexp ($parser->root);  <link rel="stylesheet" href="/www/style/html/xhtml"/>
   
 print q[<html xmlns="http://www.w3.org/1999/xhtml">  
 <head><title></title>  
94  </head>  </head>
95  <body>];  <body>
96    <h1>Regular expression visualizer</h1>
97    
98  my @regexp;  <p>Input: <code>], $eregexp, q[</code></p>];
 while (@regexp) {  
   my $nodes = shift @regexp;  
99    
100    my $index = get_graph_index ($nodes);  if (@error) {
101    print "<section><h1>Regexp #$index</h1>\n\n";    print q[<ul>];
102      print join '', @error;
103      print q[</ul>];
104    }
105    
106    my $g = generate_graph ($nodes);  while ($v->has_regexp_node) {
107    print $g->as_svg;    my ($g, $index) = $v->next_graph;
108    
109      print "<section><h2>Regexp #$index</h2>\n\n";
110      print $g->as_svg;
111    print "</section>\n";    print "</section>\n";
112  }  }
113    
114  print q[</body></html>];  print $footer;
   
 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  
115    
116    print q[</body></html>];
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.6
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24