/[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.3 by wakaba, Sun Dec 7 11:46:05 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;  use FindBin;
7  use lib qq[$FindBin::Bin/../lib];  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::Perl58;  
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::Perl58->new;  my $lang = $cgi->get_parameter ('l') // 'perl58';
20    my $class = $lang eq 'js'
21        ? '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 $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      push @error, $r;
57    });
58    
59  eval {  eval {
60    $parser->parse ($regexp);    $parser->parse ($regexp);
61  };  };
 my $eregexp = htescape $regexp;  
62    
63  if ($parser->errnum) {  if ($parser->errnum) {
64    binmode STDOUT, ':encoding(utf-8)';    binmode STDOUT, ':encoding(utf-8)';
65    print "Content-Type: text/html; charset=utf-8\n\n";    print "Content-Type: text/html; charset=utf-8\n\n";
66    print q[<!DOCTYPE HTML><html lang=en>    print q[<!DOCTYPE HTML><html lang=en>
67  <title>Regular expression visualizer: $eregexp</title>  <title>Regular expression visualizer: ], $eregexp, q[</title>
68  <link rel="stylesheet" href="/www/style/html/xhtml"/>  <link rel="stylesheet" href="/www/style/html/xhtml">
69  </head>  
 <body>  
70  <h1>Regular expression visualizer</h1>  <h1>Regular expression visualizer</h1>
71    
72  <p>Input: <code>], $eregexp, q[</code></p>  <p>Input: <code>], $eregexp, q[</code></p>
73    
74  <p>Error: ], htescape ($parser->errmsg);  <p>Error:
75    <ul>];
76      print join '', @error;
77      print q[</ul>];
78    
79      print $footer;
80    
81    exit;    exit;
82  }  }
83    
# Line 48  binmode STDOUT, ':encoding(utf-8)'; Line 89  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 q[<html lang="en" xmlns="http://www.w3.org/1999/xhtml">  print q[<html lang="en" xmlns="http://www.w3.org/1999/xhtml">
92  <head><title>Regular expression visualizer: $eregexp</title>  <head><title>Regular expression visualizer: ], $eregexp, q[</title>
93  <link rel="stylesheet" href="/www/style/html/xhtml"/>  <link rel="stylesheet" href="/www/style/html/xhtml"/>
94  </head>  </head>
95  <body>  <body>
# Line 56  print q[<html lang="en" xmlns="http://ww Line 97  print q[<html lang="en" xmlns="http://ww
97    
98  <p>Input: <code>], $eregexp, q[</code></p>];  <p>Input: <code>], $eregexp, q[</code></p>];
99    
100    if (@error) {
101      print q[<ul>];
102      print join '', @error;
103      print q[</ul>];
104    }
105    
106  while ($v->has_regexp_node) {  while ($v->has_regexp_node) {
107    my ($g, $index) = $v->next_graph;    my ($g, $index) = $v->next_graph;
108    
# Line 64  while ($v->has_regexp_node) { Line 111  while ($v->has_regexp_node) {
111    print "</section>\n";    print "</section>\n";
112  }  }
113    
114  print q[</body></html>];  print $footer;
115    
116    print q[</body></html>];
Legend:
Removed from v.1.3  
changed lines
  Added in v.1.6
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24