You cannot select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
473 lines
14 KiB
HTML
473 lines
14 KiB
HTML
<!doctype html>
|
|
<html lang="en-us">
|
|
<head>
|
|
<meta http-equiv="Content-Type" content="text/html; charset=utf-8">
|
|
<title>WebPerl Regex Tester</title>
|
|
|
|
<!-- ----- WebPerl - http://webperl.zero-g.net -----
|
|
|
|
Copyright (c) 2018 Hauke Daempfling (haukex@zero-g.net)
|
|
at the Leibniz Institute of Freshwater Ecology and Inland Fisheries (IGB),
|
|
Berlin, Germany, http://www.igb-berlin.de
|
|
|
|
This program is free software; you can redistribute it and/or modify
|
|
it under the same terms as Perl 5 itself: either the GNU General Public
|
|
License as published by the Free Software Foundation (either version 1,
|
|
or, at your option, any later version), or the "Artistic License" which
|
|
comes with Perl 5.
|
|
|
|
This program is distributed in the hope that it will be useful, but
|
|
WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
See the licenses for details.
|
|
|
|
You should have received a copy of the licenses along with this program.
|
|
If not, see http://perldoc.perl.org/index-licence.html
|
|
-->
|
|
|
|
<link rel="stylesheet" href="https://cdnjs.cloudflare.com/ajax/libs/normalize/8.0.0/normalize.min.css"
|
|
integrity="sha256-oSrCnRYXvHG31SBifqP2PM1uje7SJUyX0nTwO2RJV54=" crossorigin="anonymous" />
|
|
<style>
|
|
body {
|
|
margin: 0.4em;
|
|
}
|
|
div {
|
|
font-family: Calibri, Ubuntu, "Droid Sans", Tahoma, Arial, Helvetica, sans-serif;
|
|
}
|
|
pre,tt,textarea {
|
|
font-family: Consolas, "Ubuntu Mono", "Droid Sans Mono", "Lucida Console", "Courier New", Courier, monospace;
|
|
}
|
|
pre {
|
|
margin: 0;
|
|
}
|
|
.sample {
|
|
border: 1px solid black;
|
|
margin: 0.2em;
|
|
padding: 0.2em;
|
|
min-width: 10em;
|
|
min-height: 1em;
|
|
display: flow-root;
|
|
}
|
|
pre.samptxt {
|
|
padding: 2px;
|
|
display: inline-block;
|
|
}
|
|
textarea.samp_ta {
|
|
min-width: 10em;
|
|
min-height: 1em;
|
|
max-width: calc(100% - 1.5em);
|
|
width: 100%;
|
|
border: 1px solid grey;
|
|
padding: 1px;
|
|
display: inline-block;
|
|
}
|
|
.closebtn {
|
|
float: right;
|
|
cursor: pointer;
|
|
}
|
|
.re_warns {
|
|
clear: both;
|
|
background-color: rgba(255,255,200,255);
|
|
}
|
|
.re_errors {
|
|
background-color: rgba(255,200,200,255);
|
|
}
|
|
.nomatch {
|
|
background-color: rgba(200,200,200,255);
|
|
}
|
|
.match {
|
|
background-color: lightblue;
|
|
border: 1px solid blue;
|
|
}
|
|
.capture {
|
|
background-color: lightgreen;
|
|
}
|
|
.capture.zlen {
|
|
border: 1px solid green;
|
|
}
|
|
.zlen:hover:after {
|
|
content: " ";
|
|
}
|
|
</style>
|
|
|
|
<script src="webperl.js"></script>
|
|
<!--script src="https://webperlcdn.zero-g.net/v0.03-beta/webperl.js"
|
|
integrity="sha256-PWdMdWEx3axFU/29XiOPUwenmlsBM+5f+kc2omoKxPs=" crossorigin="anonymous"></script-->
|
|
<script src="https://code.jquery.com/jquery-3.3.1.min.js"
|
|
integrity="sha256-FgpCb/KJQlLNfOu91ta32o/NMZxltwRo8QtmkMRdAu8=" crossorigin="anonymous"></script>
|
|
|
|
<script type="text/perl">
|
|
use warnings;
|
|
use 5.028;
|
|
use WebPerl qw/js/;
|
|
use File::Temp qw/tempfile/;
|
|
use Data::Dumper ();
|
|
my $jq = js('jQuery');
|
|
|
|
sub pp { Data::Dumper->new([@_])->Useqq(1)->Terse(1)->Pair('=>')
|
|
->Sortkeys(1)->Quotekeys(0)->Indent(0)->Purity(1)->Dump }
|
|
|
|
$jq->('#perlinfo')->text("perl $^V");
|
|
|
|
sub sample_init {
|
|
my $samp = shift;
|
|
my $samptxt = $samp->children(".samptxt");
|
|
my $samp_ta = $jq->('<textarea/>', {class=>"samp_ta"});
|
|
$samp_ta->hide();
|
|
$samp_ta->appendTo($samp);
|
|
my $closebtn = $jq->('<div/>', {html=>"🗙",class=>"closebtn",
|
|
title=>"Delete Sample"});
|
|
$closebtn->appendTo($samp);
|
|
$jq->('<pre/>', {class=>'re_warns'})->appendTo($samp);
|
|
$jq->('<pre/>', {class=>'re_errors'})->appendTo($samp);
|
|
$samp->click(sub {
|
|
return if $samp_ta->is(':visible');
|
|
$samp_ta->height($samptxt->height);
|
|
$samp_ta->val($samptxt->text);
|
|
$samptxt->hide;
|
|
$samp_ta->show;
|
|
$samp_ta->focus;
|
|
});
|
|
$samp_ta->focusout(sub {
|
|
$samptxt->text($samp_ta->val);
|
|
$samptxt->height($samp_ta->height);
|
|
$samp_ta->hide;
|
|
$samptxt->show;
|
|
update();
|
|
});
|
|
$samp_ta->on('input', sub {
|
|
$samp_ta->height($samp_ta->[0]->{scrollHeight}-2); # subtract padding
|
|
});
|
|
$closebtn->click(sub { $samp->remove; update() });
|
|
}
|
|
$jq->(".sample")->each(sub{ sample_init($jq->($_[1])) });
|
|
|
|
my $addsamp = $jq->("#addsamp");
|
|
sub newsamp {
|
|
my $text = @_ ? shift : 'New Sample';
|
|
my $samptxt = $jq->('<pre/>',{class=>"samptxt",text=>$text});
|
|
my $samp = $jq->('<div/>',{class=>"sample"})->append($samptxt);
|
|
$samp->insertBefore($addsamp->parent);
|
|
sample_init($samp);
|
|
update();
|
|
return $samp;
|
|
}
|
|
$addsamp->click(sub { newsamp('')->click });
|
|
|
|
our $re_debug=0;
|
|
my $ta_debugout = $jq->('#debugout');
|
|
my $re_debug_hide = $jq->('#re_debug_hide');
|
|
$jq->('#re_debug')->click(sub {
|
|
open my $olderr, '>&', \*STDERR or die "dup STDERR: $!";
|
|
my ($fh,$fn) = tempfile(UNLINK=>1);
|
|
open STDERR, '>&', $fh or die "open STDERR: $!";
|
|
|
|
{ local $re_debug=1; update(); }
|
|
|
|
open STDERR, '>&', $olderr or die "dup \$olderr: $!";
|
|
close $fh;
|
|
my $err = do { open my $fh, '<', $fn or die $!; local $/; <$fh> };
|
|
|
|
$ta_debugout->text($err);
|
|
$ta_debugout->show;
|
|
$re_debug_hide->show;
|
|
});
|
|
$re_debug_hide->click(sub{
|
|
$re_debug_hide->hide;
|
|
$ta_debugout->hide;
|
|
});
|
|
$re_debug_hide->hide;
|
|
$ta_debugout->hide;
|
|
|
|
my $sampcodebtn = $jq->('#sampcodebtn');
|
|
my $codecopy = $jq->('#codecopy');
|
|
my $samplecode_ta = $jq->('#samplecode');
|
|
$sampcodebtn->click(sub{
|
|
if ($samplecode_ta->is(':visible')) {
|
|
$samplecode_ta->hide;
|
|
$codecopy->hide;
|
|
$sampcodebtn->text('Show Example Perl Code');
|
|
}
|
|
else {
|
|
$samplecode_ta->show;
|
|
$codecopy->show;
|
|
$sampcodebtn->text('Hide Example Perl Code');
|
|
update();
|
|
}
|
|
});
|
|
$codecopy->click(sub {
|
|
$samplecode_ta->[0]->select;
|
|
js(q{ document.execCommand("copy"); });
|
|
});
|
|
$samplecode_ta->hide;
|
|
$codecopy->hide;
|
|
|
|
my $precodebtn = $jq->('#precodebtn');
|
|
my $precode_ta = $jq->('#precode');
|
|
$precodebtn->click(sub{
|
|
if ($precode_ta->is(':visible')) {
|
|
$precode_ta->hide;
|
|
$precodebtn->text("Add Preamble Code");
|
|
}
|
|
else {
|
|
$precode_ta->show;
|
|
$precodebtn->text("Disable Preamble Code");
|
|
}
|
|
update();
|
|
});
|
|
$precode_ta->hide;
|
|
$precode_ta->change(\&update);
|
|
$precode_ta->keyup( \&update);
|
|
|
|
my $thisurl_ta = $jq->("#thisurl");
|
|
my $ta_regex = $jq->("#regex");
|
|
my $ta_flags = $jq->("#flags");
|
|
my $warnmsgs = $jq->("#warnmsgs");
|
|
$ta_regex->change(\&update);
|
|
$ta_regex->keyup( \&update);
|
|
$ta_flags->change(\&update);
|
|
$ta_flags->keyup( \&update);
|
|
update();
|
|
|
|
$ta_regex->on('input', sub {
|
|
$ta_regex->height($ta_regex->[0]->{scrollHeight});
|
|
});
|
|
|
|
sub run_code {
|
|
my ($code,$inp) = @_;
|
|
my @warns;
|
|
my $ok = do {
|
|
local $SIG{__WARN__} = sub { push @warns, shift };
|
|
package run_code;
|
|
our $input = $inp;
|
|
our @output = ();
|
|
eval "$code;1" };
|
|
my $err = $ok ? undef : $@||"Unknown error";
|
|
defined && s/\bat .+? line \d+(?:\.$|,\h)//mg for (@warns,$err);
|
|
chomp(@warns);
|
|
return { warns=>\@warns, $ok ? (out=>\@run_code::output) : (err=>$err) }
|
|
}
|
|
|
|
sub update {
|
|
my $regex = $ta_regex->val;
|
|
my $flags = $ta_flags->val;
|
|
my $precode = $precode_ta->is(':visible') ? $precode_ta->val : '';
|
|
$precode .= "\n" if length $precode && substr($precode,-1) ne "\n";
|
|
my $regex_str = 'm{'.$regex.'}'.$flags;
|
|
$re_debug and say STDERR "##### ##### ##### $regex_str ##### ##### #####";
|
|
$re_debug and !length($regex) and say STDERR
|
|
"NOTE: The empty regex $regex_str requires a workaround with /(?:)/," # https://www.perlmonks.org/?node_id=1221517
|
|
."\n this will be reflected in the debug output";
|
|
|
|
my $warn = '';
|
|
$warn .= "Notice: The empty pattern has special behavior, see perlop!\n"
|
|
." Here, a workaround is used so it acts as a true empty pattern.\n" unless length $regex;
|
|
$warn .= "\\n is recommended over literal newlines\n" if $regex=~/\n/ && $flags!~/x/;
|
|
$warn .= "\\t is recommended over literal tabs\n" if $regex=~/\t/ && $flags!~/x/;
|
|
$warnmsgs->text($warn);
|
|
|
|
# apply regex to the samples and do highlighting
|
|
my @samps;
|
|
for my $sample (map {$jq->($_)} $jq->('.sample')->@*) {
|
|
my $samptxt = $sample->children('.samptxt');
|
|
my $re_warns = $sample->children('.re_warns');
|
|
my $re_errs = $sample->children('.re_errors');
|
|
my $text = $samptxt->text;
|
|
$re_debug and say STDERR "----- ----- ----- ",pp($text)," ----- ----- -----";
|
|
push @samps, $text;
|
|
my $code = $precode . ($re_debug?'use re "debug";':'')
|
|
. (length($regex)?'':"''=~/(?:)/$flags;")
|
|
. 'push @output,[[@-],[@+]] ' . ($flags=~/g/?'while':'if') . ' $input=~'.$regex_str;
|
|
my $rv = run_code($code, $text);
|
|
$re_warns->text( join "\n", $rv->{warns}->@* );
|
|
if ( $rv->{out} && $rv->{out}->@* ) {
|
|
$re_errs->text('');
|
|
$samptxt->removeClass('nomatch');
|
|
my %hi;
|
|
$re_debug and say STDERR '@-/@+ are ',pp($rv->{out});
|
|
for my $i (0..$#{$rv->{out}}) {
|
|
my ($s,$e) = $rv->{out}[$i]->@*;
|
|
for my $j (0..$#$e) { # Use @+ to count all capture groups instead of @-!
|
|
next if !defined($$s[$j]) && !defined($$e[$j]);
|
|
my $name = "Match ".($i+1).($j?" Capture Group $j":"");
|
|
if ($$s[$j]==$$e[$j]) {
|
|
push @{ $hi{$$s[$j]}{
|
|
$j==0 ? 'zlen_match' : 'zlen_cap' }
|
|
}, $name }
|
|
else {
|
|
push @{ $hi{$$s[$j]}{ $j==0 ? 'match' : 'cap' } }, $name;
|
|
$hi{$$e[$j]}{end}++ }
|
|
}
|
|
}
|
|
$re_debug and say STDERR 'highlights are ',pp(\%hi);
|
|
my $html='';
|
|
my $p=0;
|
|
for my $i (sort {$a<=>$b} keys %hi) {
|
|
$html .= substr($text,$p,$i-$p);
|
|
$html .= '</span>' x ($hi{$i}{end}//0);
|
|
$html .= "<span class='zlen match' title='$_'></span>" for @{ $hi{$i}{zlen_match}//[] };
|
|
$html .= "<span class='zlen capture' title='$_'></span>" for @{ $hi{$i}{zlen_cap}//[] };
|
|
$html .= "<span class='match' title='$_'>" for @{ $hi{$i}{match}//[] };
|
|
$html .= "<span class='capture' title='$_'>" for @{ $hi{$i}{cap}//[] };
|
|
} continue { $p=$i }
|
|
$html .= substr($text,$p);
|
|
$samptxt->html($html);
|
|
}
|
|
else {
|
|
$re_errs->text($rv->{out} ? '' : $rv->{err});
|
|
$rv->{out} && $samptxt->addClass('nomatch');
|
|
$samptxt->text($text);
|
|
}
|
|
}
|
|
|
|
# generate sample Perl code
|
|
if ($samplecode_ta->is(':visible')) {
|
|
my $sampcode = <<~'ENDCODE';
|
|
use warnings;
|
|
use strict;
|
|
|
|
my @samples = (
|
|
__SAMPLES__
|
|
);
|
|
|
|
for my $sample (@samples) {
|
|
print "### Sample: \"$sample\"\n";
|
|
ENDCODE
|
|
$sampcode =~ s{__SAMPLES__}{ join ",\n", map {" ".pp($_)} @samps }e;
|
|
$sampcode .= $precode=~s/^/ /mgr if length $precode;
|
|
if ($flags=~/g/) {
|
|
$sampcode .= <<~'ENDCODE';
|
|
while ( $sample =~ __REGEX__ ) {
|
|
print "Match! \"$&\"\n";
|
|
}
|
|
ENDCODE
|
|
}
|
|
else {
|
|
$sampcode .= <<~'ENDCODE';
|
|
if ( $sample =~ __REGEX__ ) {
|
|
print "Match! \"$&\"\n";
|
|
}
|
|
else {
|
|
print "No match!\n";
|
|
}
|
|
ENDCODE
|
|
}
|
|
my $re = $regex_str;
|
|
if ( $re=~/\n/ && $flags=~/x/ ) {
|
|
$re =~ s/^/ /mg;
|
|
$re = "\n".$re;
|
|
}
|
|
$sampcode =~ s/__REGEX__/$re/;
|
|
$sampcode .= "}\n";
|
|
$samplecode_ta->text($sampcode);
|
|
}
|
|
|
|
# generate URL
|
|
my $i=1;
|
|
my $hash = '#' . $jq->param( { regex=>$regex, flags=>$flags,
|
|
( length $precode ? (pre=>$precode) : () ),
|
|
map { "samp".$i++ => $_ } @samps } );
|
|
my $baseurl = js('window.location')->{href} =~ s/#.*\z//r;
|
|
$thisurl_ta->text( $baseurl . $hash );
|
|
}
|
|
|
|
$jq->('#urlcopy')->click(sub {
|
|
$thisurl_ta->[0]->select;
|
|
js(q{ document.execCommand("copy"); });
|
|
});
|
|
|
|
sub hashchange {
|
|
my $hash = js('window.location')->{hash};
|
|
return unless $hash=~/^#.*\bregex=/;
|
|
my %res;
|
|
my $decode = js('decodeURIComponent');
|
|
for my $c (split /&/, substr $hash, 1) {
|
|
my ($k,$v) = split /=/, $c;
|
|
$res{ $decode->($k=~tr/+/ /r) } = $decode->($v=~tr/+/ /r);
|
|
}
|
|
if (exists $res{regex} && exists $res{flags}) {
|
|
$ta_regex->text($res{regex});
|
|
$ta_regex->height($ta_regex->[0]->{scrollHeight});
|
|
$ta_flags->text($res{flags});
|
|
if (exists $res{pre}) {
|
|
$precode_ta->text($res{pre});
|
|
$precode_ta->show;
|
|
$precodebtn->text("Disable Preamble Code");
|
|
}
|
|
if (exists $res{samp1}) {
|
|
$jq->(".sample")->remove();
|
|
for (my $i=1;exists $res{"samp$i"};$i++) {
|
|
newsamp($res{"samp$i"});
|
|
}
|
|
}
|
|
}
|
|
else { js('window.location')->{hash}='' }
|
|
}
|
|
hashchange();
|
|
js('$(window)')->on('hashchange',\&hashchange);
|
|
|
|
</script>
|
|
|
|
</head>
|
|
<body>
|
|
|
|
<div style="margin-bottom:1em;font-size:1.2em"><b>Perl Regex Tester</b>
|
|
- powered by <a href="http://webperl.zero-g.net" target="_blank">WebPerl</a> (beta)</div>
|
|
|
|
<div style="margin-bottom:1em">
|
|
<div><button id="precodebtn">Add Preamble Code</button></div>
|
|
<textarea id="precode" rows="3" cols="80">
|
|
my $x = "foo"; # example
|
|
</textarea>
|
|
</div>
|
|
|
|
<div style="margin-bottom:1em">
|
|
<div><tt style="vertical-align: top;">m{</tt
|
|
><textarea id="regex" rows="1" cols="50" style="height:1.2em"
|
|
title="Perl Regular Expression">wo(.)</textarea
|
|
><tt style="vertical-align: text-bottom;">}</tt
|
|
><textarea id="flags" rows="1" cols="5" style="height:1.2em"
|
|
title="Flags for Regular Expression">gi</textarea></div>
|
|
<pre id="warnmsgs" class="re_warns"></pre>
|
|
</div>
|
|
|
|
<div class="sample">
|
|
<pre class="samptxt">Hello, World!</pre>
|
|
</div>
|
|
<div class="sample">
|
|
<pre class="samptxt">Oh, what a wonderful world!</pre>
|
|
</div>
|
|
<div style="text-align:right">
|
|
<button id="addsamp">Add Sample</button>
|
|
</div>
|
|
|
|
<div style="margin-top:0.5em">
|
|
<button id="sampcodebtn">Show Example Perl Code</button>
|
|
<span id="codecopy" style="cursor:pointer" title="Copy to Clipboard">📋</span><br/>
|
|
<textarea id="samplecode" rows="20" cols="80" style="font-size:0.8em" readonly="readonly"></textarea>
|
|
</div>
|
|
|
|
<div style="margin-top:0.5em">
|
|
<div>
|
|
<button id="re_debug"><tt>use re "debug";</tt></button>
|
|
<button id="re_debug_hide">Hide</button>
|
|
</div>
|
|
<textarea id="debugout" rows="25" cols="80" readonly="readonly"></textarea>
|
|
</div>
|
|
|
|
<div style="margin-top:0.5em">
|
|
URL:
|
|
<textarea id="thisurl" rows="2" cols="80" style="height:2.4em;font-size:0.8em" readonly="readonly"></textarea>
|
|
<span id="urlcopy" style="cursor:pointer" title="Copy to Clipboard">📋</span>
|
|
</div>
|
|
|
|
<pre id="perlinfo" style="margin-top:0.5em"></pre>
|
|
|
|
<div style="margin-top:1em;font-size:0.8em">
|
|
Author, Copyright, and License: see
|
|
<a href="https://github.com/haukex/webperl/blob/master/web/regex_demo.html" target="_blank">the source code of this file</a>.<br/>
|
|
</div>
|
|
|
|
</body>
|
|
</html>
|