Permalink
Cannot retrieve contributors at this time
#!/usr/bin/perl | |
use strict; | |
use warnings; | |
use CGI::Carp qw(fatalsToBrowser); | |
use Path::Tiny; | |
use lib path (__FILE__)->parent->parent->child ('lib')->stringify; | |
use Web::Encoding; | |
sub htescape ($) { | |
my $s = shift; | |
$s =~ s/&/&/g; | |
$s =~ s/</</g; | |
$s =~ s/"/"/g; | |
return $s; | |
} # htescape | |
my %qp = map { s/%([0-9A-Fa-f]{2})/pack 'C', hex $1/ge; $_ } map { split /=/, $_, 2 } split /&/, $ENV{QUERY_STRING} // ''; | |
my $regexp = decode_web_utf8 $qp{s} // ''; | |
$regexp = '(?:)' unless length $regexp; | |
my $eregexp = htescape $regexp; | |
my $lang = $qp{l} // 'perl58'; | |
my $class = $lang eq 'js' | |
? 'Regexp::Parser::JavaScript' | |
: 'Regexp::Parser::Perl58'; | |
eval qq{ require $class } or die $@; | |
my $parser = $class->new; | |
my $footer = q[ | |
<footer> | |
[<a href="input">Input</a>] | |
[<a href="../doc/readme">Source</a>] | |
</footer> | |
]; | |
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"> | |
<h1>Regular expression visualizer</h1> | |
<p>Input: <code>], $eregexp, q[</code></p> | |
<p>Error: | |
<ul>]; | |
print join '', @error; | |
print q[</ul>]; | |
print $footer; | |
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 $footer; | |
print q[</body></html>]; |