Skip to content

Commit 47bc0c4

Browse files
haukexhaukex
committed
Prepared run_code for async calling
1 parent 2959d27 commit 47bc0c4

File tree

1 file changed

+66
-57
lines changed

1 file changed

+66
-57
lines changed

‎web/regex_demo.html‎

Lines changed: 66 additions & 57 deletions
Original file line numberDiff line numberDiff line change
@@ -109,11 +109,13 @@
109109

110110
sub sample_init {
111111
my $samp = shift;
112+
state $samp_id = 'a';
113+
$samp->attr('id',"samp_".$samp_id++) unless $samp->attr('id');
112114
my $samptxt = $samp->children(".samptxt");
113115
my $samp_ta = $jq->('<textarea/>', {class=>"samp_ta"});
114116
$samp_ta->hide();
115117
$samp_ta->appendTo($samp);
116-
my $closebtn = $jq->('<div/>', {html=>"&#x1F5D9;",class=>"closebtn",
118+
my $closebtn = $jq->('<div/>', {html=>"&#x274E;",class=>"closebtn",
117119
title=>"Delete Sample"});
118120
$closebtn->appendTo($samp);
119121
$jq->('<pre/>', {class=>'re_warns'})->appendTo($samp);
@@ -248,18 +250,16 @@
248250
update();
249251

250252
sub run_code {
251-
my ($code,$inp) = @_;
252-
my @warns;
253+
my ($context,$code,$input,$callback) = @_;
254+
my (@warns,@output);
253255
my $ok = do {
254256
local $SIG{__WARN__} = sub { push @warns, shift };
255-
package run_code;
256-
our $input = $inp;
257-
our @output = ();
258-
eval "$code;1" };
257+
eval "package RunCode {$code\n};1" };
259258
my $err = $ok ? undef : $@||"Unknown error";
260259
defined && s/\bat .+? line \d+(?:\.$|,\h)//mg for (@warns,$err);
261260
chomp(@warns);
262-
return { warns=>\@warns, $ok ? (out=>\@run_code::output) : (err=>$err) }
261+
$callback->( { ctx=>$context, warns=>\@warns,
262+
$ok ? (out=>\@output) : (err=>$err) } );
263263
}
264264

265265
sub update {
@@ -275,7 +275,6 @@
275275
my $precode = $precode_ta->is(':visible') ? $precode_ta->val : '';
276276
$precode .= "\n" if length $precode && substr($precode,-1) ne "\n";
277277
my $regex_str = 'm{'.$regex.'}'.$flags;
278-
$re_debug and say STDERR "##### ##### ##### $regex_str ##### ##### #####";
279278
$re_debug and !length($regex) and say STDERR
280279
"NOTE: The empty regex $regex_str requires a workaround with /(?:)/," # https://www.perlmonks.org/?node_id=1221517
281280
."\n this will be reflected in the debug output";
@@ -288,61 +287,18 @@
288287
state $warnmsgs = $jq->("#warnmsgs");
289288
$warnmsgs->text($warn);
290289

291-
# apply regex to the samples and do highlighting
292290
my @samps;
293291
for my $sample (map {$jq->($_)} $jq->('.sample')->@*) {
294292
my $samptxt = $sample->children('.samptxt');
295-
my $re_warns = $sample->children('.re_warns');
296-
my $re_errs = $sample->children('.re_errors');
297293
my $text = $samptxt->text;
298-
$re_debug and say STDERR "----- ----- ----- ",pp($text)," ----- ----- -----";
299-
push @samps, $text;
300-
my $code = $precode . ($re_debug?'use re "debug";':'')
294+
push @samps, $text; # for use below
295+
my $code = $precode . ($re_debug?'use re "debug";'
296+
. 'say STDERR '.pp('##### ##### ##### '.pp($text).' =~ '.pp($regex_str).' ##### ##### #####').';':'')
301297
. (length($regex)?'':"''=~/(?:)/$flags;")
302298
. 'push @output,[[@-],[@+]] ' . ($flags=~/g/?'while':'if') . ' $input=~'.$regex_str;
303-
my $rv = run_code($code, $text);
304-
$re_warns->text( join "\n", $rv->{warns}->@* );
305-
if ( $rv->{out} && $rv->{out}->@* ) {
306-
$re_errs->text('');
307-
$samptxt->removeClass('nomatch');
308-
my %hi;
309-
$re_debug and say STDERR '@-/@+ are ',pp($rv->{out});
310-
for my $i (0..$#{$rv->{out}}) {
311-
my ($s,$e) = $rv->{out}[$i]->@*;
312-
for my $j (0..$#$e) { # Use @+ to count all capture groups instead of @-!
313-
next if !defined($$s[$j]) && !defined($$e[$j]);
314-
my $name = "Match ".($i+1).($j?" Capture Group $j":"");
315-
if ($$s[$j]==$$e[$j]) {
316-
push @{ $hi{$$s[$j]}{
317-
$j==0 ? 'zlen_match' : 'zlen_cap' }
318-
}, $name }
319-
else {
320-
push @{ $hi{$$s[$j]}{ $j==0 ? 'match' : 'cap' } }, $name;
321-
$hi{$$e[$j]}{end}++ }
322-
}
323-
}
324-
$re_debug and say STDERR 'highlights are ',pp(\%hi);
325-
my $html='';
326-
my $p=0;
327-
for my $i (sort {$a<=>$b} keys %hi) {
328-
$html .= substr($text,$p,$i-$p);
329-
$html .= '</span>' x ($hi{$i}{end}//0);
330-
$html .= "<span class='zlen match' title='$_'></span>" for @{ $hi{$i}{zlen_match}//[] };
331-
$html .= "<span class='zlen capture' title='$_'></span>" for @{ $hi{$i}{zlen_cap}//[] };
332-
$html .= "<span class='match' title='$_'>" for @{ $hi{$i}{match}//[] };
333-
$html .= "<span class='capture' title='$_'>" for @{ $hi{$i}{cap}//[] };
334-
} continue { $p=$i }
335-
$html .= substr($text,$p);
336-
$samptxt->html($html);
337-
}
338-
else {
339-
$re_errs->text($rv->{out} ? '' : $rv->{err});
340-
$rv->{out} && $samptxt->addClass('nomatch');
341-
$samptxt->text($text);
342-
}
299+
run_code($sample->attr('id'), $code, $text, \&run_code_callback);
343300
}
344301

345-
# generate sample Perl code
346302
if ($samplecode_ta->is(':visible')) {
347303
my $sampcode = <<~'ENDCODE';
348304
use warnings;
@@ -361,13 +317,15 @@
361317
$sampcode .= <<~'ENDCODE';
362318
while ( $sample =~ __REGEX__ ) {
363319
print "Match! \"$&\"\n";
320+
# can use $1, $2, etc. here
364321
}
365322
ENDCODE
366323
}
367324
else {
368325
$sampcode .= <<~'ENDCODE';
369326
if ( $sample =~ __REGEX__ ) {
370327
print "Match! \"$&\"\n";
328+
# can use $1, $2, etc. here
371329
}
372330
else {
373331
print "No match!\n";
@@ -384,7 +342,6 @@
384342
$samplecode_ta->text($sampcode);
385343
}
386344

387-
# generate URL
388345
my $i=1;
389346
my $hash = '#' . $jq->param( { regex=>$regex, flags=>$flags,
390347
( length $precode ? (pre=>$precode) : () ),
@@ -393,6 +350,58 @@
393350
my $baseurl = js('window.location')->{href} =~ s/#.*\z//r;
394351
$thisurl_ta->text( $baseurl . $hash );
395352
}
353+
sub run_code_callback {
354+
my $rv = shift;
355+
my $sample = $jq->('#'.$rv->{ctx});
356+
if (!$sample->{length}) {
357+
warn "got callback for nonexistent sample ".$rv->{context};
358+
return }
359+
my $samptxt = $sample->children('.samptxt');
360+
my $re_warns = $sample->children('.re_warns');
361+
my $re_errs = $sample->children('.re_errors');
362+
my $text = $samptxt->text;
363+
$re_warns->text( join "\n", $rv->{warns}->@* );
364+
if ( $rv->{out} && $rv->{out}->@* ) {
365+
$re_errs->text('');
366+
$samptxt->removeClass('nomatch');
367+
my %hi;
368+
$re_debug and say STDERR '@-/@+ are ',pp($rv->{out});
369+
for my $i (0..$#{$rv->{out}}) {
370+
my ($s,$e) = $rv->{out}[$i]->@*;
371+
for my $j (0..$#$e) { # Use @+ to count all capture groups instead of @-!
372+
next if !defined($$s[$j]) && !defined($$e[$j]);
373+
my $name = "Match ".($i+1).($j?" Capture Group $j":"");
374+
if ($$s[$j]==$$e[$j]) {
375+
push @{ $hi{$$s[$j]}{
376+
$j==0 ? 'zlen_match' : 'zlen_cap' }
377+
}, $name }
378+
else {
379+
push @{ $hi{$$s[$j]}{ $j==0 ? 'match' : 'cap' } }, $name;
380+
$hi{$$e[$j]}{end}++ }
381+
}
382+
}
383+
$re_debug and say STDERR 'highlights are ',pp(\%hi);
384+
my $html='';
385+
my $p=0;
386+
for my $i (sort {$a<=>$b} keys %hi) {
387+
$html .= substr($text,$p,$i-$p);
388+
#TODO: capture groups overlapping following matches don't work right
389+
# e.g. "Oh, what a wonderful world!" =~ m{a(.)(?=.(....))}gi
390+
$html .= '</span>' x ($hi{$i}{end}//0);
391+
$html .= "<span class='zlen match' title='$_'></span>" for @{ $hi{$i}{zlen_match}//[] };
392+
$html .= "<span class='zlen capture' title='$_'></span>" for @{ $hi{$i}{zlen_cap}//[] };
393+
$html .= "<span class='match' title='$_'>" for @{ $hi{$i}{match}//[] };
394+
$html .= "<span class='capture' title='$_'>" for @{ $hi{$i}{cap}//[] };
395+
} continue { $p=$i }
396+
$html .= substr($text,$p);
397+
$samptxt->html($html);
398+
}
399+
else {
400+
$re_errs->text($rv->{out} ? '' : $rv->{err});
401+
$rv->{out} && $samptxt->addClass('nomatch');
402+
$samptxt->text($text);
403+
}
404+
}
396405

397406
sub hashchange {
398407
my $hash = js('window.location')->{hash};

0 commit comments

Comments
 (0)