regexp/visualizer/regexp.cgi

#!/usr/bin/perl
use strict;
use warnings;
use CGI::Carp qw(fatalsToBrowser);

use FindBin;
use lib qq[$FindBin::Bin/../lib];
use lib q[/home/wakaba/work/manakai2/lib];
use Message::CGI::Util qw/htescape/;
use Encode;

use Message::CGI::HTTP;
my $cgi = Message::CGI::HTTP->new;

my $regexp = decode 'utf-8', $cgi->get_parameter ('s') // '';
$regexp = '(?:)' unless length $regexp;
my $eregexp = htescape $regexp;

my $lang = $cgi->get_parameter ('l') // 'perl58';
my $class = $lang eq 'js'
    ? 'Regexp::Parser::JavaScript'
    : 'Regexp::Parser::Perl58';

use UNIVERSAL::require;
$class->use or die $@;
my $parser = $class->new;

my @error;
$parser->onerror (sub {
  my %args = @_;
  my $r = '<li>';
  if ($args{level} eq 'w') {
    $r .= '<strong>Warning</strong>: ';
  } else {
    $r .= '<strong>Error</strong>: ';
  }

  $r .= htescape sprintf $args{type}, @{$args{args}};

  $r .= ': <code>';
  $r .= htescape substr ${$args{valueref}}, 0, $args{pos_start};
  $r .= '<mark>';
  $r .= htescape substr ${$args{valueref}},
      $args{pos_start}, $args{pos_end} - $args{pos_start};
  $r .= '</mark>';
  $r .= htescape substr ${$args{valueref}}, $args{pos_end};
  $r .= '</code></li>';

  push @error, $r;
});

eval {
  $parser->parse ($regexp);
};

if ($parser->errnum) {
  binmode STDOUT, ':encoding(utf-8)';
  print "Content-Type: text/html; charset=utf-8\n\n";
  print q[<!DOCTYPE HTML><html lang=en>
<title>Regular expression visualizer: ], $eregexp, q[</title>
<link rel="stylesheet" href="/www/style/html/xhtml"/>
</head>
<body>
<h1>Regular expression visualizer</h1>

<p>Input: <code>], $eregexp, q[</code></p>

<p>Error:
<ul>];
  print join '', @error;
  print q[</ul>];

  exit;
}

require Regexp::Visualize::Simple;
my $v = Regexp::Visualize::Simple->new;
$v->push_regexp_node ($parser->root);

binmode STDOUT, ':encoding(utf-8)';
print "Content-Type: application/xhtml+xml; charset=utf-8\n\n";

print q[<html lang="en" xmlns="http://www.w3.org/1999/xhtml">
<head><title>Regular expression visualizer: ], $eregexp, q[</title>
<link rel="stylesheet" href="/www/style/html/xhtml"/>
</head>
<body>
<h1>Regular expression visualizer</h1>

<p>Input: <code>], $eregexp, q[</code></p>];

if (@error) {
  print q[<ul>];
  print join '', @error;
  print q[</ul>];
}

while ($v->has_regexp_node) {
  my ($g, $index) = $v->next_graph;

  print "<section><h2>Regexp #$index</h2>\n\n";
  print $g->as_svg;
  print "</section>\n";
}

print q[</body></html>];

1	wakaba	1.1	#!/usr/bin/perl
2			use strict;
3			use warnings;
4			use CGI::Carp qw(fatalsToBrowser);
5
6	wakaba	1.3	use FindBin;
7			use lib qq[$FindBin::Bin/../lib];
8	wakaba	1.1	use lib q[/home/wakaba/work/manakai2/lib];
9	wakaba	1.4	use Message::CGI::Util qw/htescape/;
10			use Encode;
11
12	wakaba	1.2	use Message::CGI::HTTP;
13			my $cgi = Message::CGI::HTTP->new;
14
15	wakaba	1.4	my $regexp = decode 'utf-8', $cgi->get_parameter ('s') // '';
16	wakaba	1.1	$regexp = '(?:)' unless length $regexp;
17	wakaba	1.4	my $eregexp = htescape $regexp;
18	wakaba	1.1
19	wakaba	1.4	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	wakaba	1.1
28	wakaba	1.5	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			$r .= htescape sprintf $args{type}, @{$args{args}};
39
40			$r .= ': <code>';
41			$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			push @error, $r;
50			});
51
52	wakaba	1.3	eval {
53			$parser->parse ($regexp);
54			};
55	wakaba	1.2
56			if ($parser->errnum) {
57			binmode STDOUT, ':encoding(utf-8)';
58			print "Content-Type: text/html; charset=utf-8\n\n";
59			print q[<!DOCTYPE HTML><html lang=en>
60	wakaba	1.4	<title>Regular expression visualizer: ], $eregexp, q[</title>
61	wakaba	1.2	<link rel="stylesheet" href="/www/style/html/xhtml"/>
62			</head>
63			<body>
64			<h1>Regular expression visualizer</h1>
65
66			<p>Input: <code>], $eregexp, q[</code></p>
67
68	wakaba	1.5	<p>Error:
69			<ul>];
70			print join '', @error;
71			print q[</ul>];
72
73	wakaba	1.2	exit;
74			}
75	wakaba	1.1
76	wakaba	1.3	require Regexp::Visualize::Simple;
77			my $v = Regexp::Visualize::Simple->new;
78			$v->push_regexp_node ($parser->root);
79
80	wakaba	1.1	binmode STDOUT, ':encoding(utf-8)';
81			print "Content-Type: application/xhtml+xml; charset=utf-8\n\n";
82
83	wakaba	1.2	print q[<html lang="en" xmlns="http://www.w3.org/1999/xhtml">
84	wakaba	1.4	<head><title>Regular expression visualizer: ], $eregexp, q[</title>
85	wakaba	1.2	<link rel="stylesheet" href="/www/style/html/xhtml"/>
86	wakaba	1.1	</head>
87	wakaba	1.2	<body>
88			<h1>Regular expression visualizer</h1>
89
90			<p>Input: <code>], $eregexp, q[</code></p>];
91	wakaba	1.5
92			if (@error) {
93			print q[<ul>];
94			print join '', @error;
95			print q[</ul>];
96			}
97	wakaba	1.1
98	wakaba	1.3	while ($v->has_regexp_node) {
99			my ($g, $index) = $v->next_graph;
100	wakaba	1.1
101	wakaba	1.2	print "<section><h2>Regexp #$index</h2>\n\n";
102	wakaba	1.1	print $g->as_svg;
103			print "</section>\n";
104			}
105
106			print q[</body></html>];
107