diff --git a/web/regex_tester.html b/web/regex_tester.html index 6ce2b61..ca8dde3 100644 --- a/web/regex_tester.html +++ b/web/regex_tester.html @@ -65,8 +65,11 @@ textarea.samp_ta { float: right; cursor: pointer; } -.re_warns { +.re_output { clear: both; + background-color: rgba(234,234,234,255); +} +.re_warns { background-color: rgba(255,255,200,255); } .re_errors { @@ -100,7 +103,6 @@ textarea.samp_ta { use warnings; use 5.028; use WebPerl qw/js/; -use File::Temp qw/tempfile/; use Data::Dumper (); my $jq = js('jQuery'); @@ -111,14 +113,33 @@ our $RUN_CODE_IN_IFRAME=0; my $run_code_body = <<'END_CODE'; my (@warns,@output); - #TODO Later: Capture STDOUT too? (and STDERR, instead of $SIG{__WARN__})? + + require File::Temp; + my ($fh1,$fn1) = File::Temp::tempfile(); + open my $oldout, '>&', \*STDOUT or die "dup STDOUT: $!"; + open STDOUT, '>&', $fh1 or die "open STDOUT: $!"; + my ($fh2,$fn2) = File::Temp::tempfile(); + open my $olderr, '>&', \*STDERR or die "dup STDERR: $!"; + open STDERR, '>&', $fh2 or die "open STDERR: $!"; + my $ok = do { local $SIG{__WARN__} = sub { push @warns, shift }; eval "package RunCode {$code\n};1" }; my $err = $ok ? undef : $@||"Unknown error"; + + open STDERR, '>&', $olderr or die "dup \$olderr: $!"; + close $fh2; + open STDOUT, '>&', $oldout or die "dup \$oldout: $!"; + close $fh1; + my $stdout = do { open my $fh, '<', $fn1 or die $!; local $/; <$fh> }; + my $stderr = do { open my $fh, '<', $fn2 or die $!; local $/; <$fh> }; + unlink($fn1,$fn2)==2 or warn "unlink('$fn1','$fn2'): $!"; + defined && s/\bat .+? line \d+(?:\.$|,\h)//mg for (@warns,$err); chomp(@warns); - my $rv = { ctx=>$context, warns=>\@warns, $ok ? (out=>\@output) : (err=>$err) }; + my $rv = { ctx=>$context, warns=>\@warns, + $ok ? (out=>\@output) : (err=>$err), + stdout => $stdout, stderr => $stderr }; END_CODE my $runcode_iframe; @@ -200,6 +221,7 @@ sub sample_init { my $closebtn = $jq->('
', {html=>"❎",class=>"closebtn", title=>"Delete Sample"}); $closebtn->appendTo($samp); + $jq->('', {class=>'re_output'})->appendTo($samp); $jq->('', {class=>'re_warns'})->appendTo($samp); $jq->('', {class=>'re_errors'})->appendTo($samp); $samp->click(sub { @@ -239,34 +261,7 @@ $addsamp->click(sub { newsamp('')->click }); # $re_debug is actually a parameter to update()/actual_update(), but since # we register &update as a event handler, it'll get passed varying parameters our $re_debug=0; -my $ta_debugout = $jq->('#debugout'); -my $re_debug_hide = $jq->('#re_debug_hide'); -$jq->('#re_debug')->click(sub { - #TODO: re_debug no longer works in IFrame! (ugly "workaround" below) - # Not only this capturing, but also $re_debug is unset by the time the callback gets called - open my $olderr, '>&', \*STDERR or die "dup STDERR: $!"; - my ($fh,$fn) = tempfile(); - 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> }; - unlink($fn)==1 or warn "unlink $fn: $!"; - - $err .= "\n### Please see the JavaScript console! ###\n" - if $RUN_CODE_IN_IFRAME; - $ta_debugout->val($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; +$jq->('#re_debug')->click(sub { local $re_debug=1; update() }); my $sampcodebtn = $jq->('#sampcodebtn'); my $codecopy = $jq->('#codecopy'); @@ -358,13 +353,14 @@ sub actual_update { 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 !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; + if (not length $regex) { + $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"; + if ($re_debug) # https://www.perlmonks.org/?node_id=1221517 + { $warn .= " The workaround uses /(?:)/, which you will see in the debug output.\n" } + } $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/; state $warnmsgs = $jq->("#warnmsgs"); @@ -375,10 +371,15 @@ sub actual_update { my $samptxt = $sample->children('.samptxt'); my $text = $samptxt->text; push @samps, $text; # for use below - my $code = $precode . ($re_debug?'use re "debug";' - . 'say STDERR '.pp('##### ##### ##### '.pp($text).' =~ '.pp($regex_str).' ##### ##### #####').';':'') - . (length($regex)?'':"''=~/(?:)/$flags;") - . 'push @output,[[@-],[@+]] ' . ($flags=~/g/?'while':'if') . ' $input=~'.$regex_str; + my $code = $precode . ( $re_debug ? "use re \"debug\";\n" : '' ) + . ( length($regex) ? '' : "''=~/(?:)/$flags; # // workaround\n" ) + . 'push @output,[[@-],[@+]] ' . ($flags=~/g/?'while':'if') . ' $input=~'.$regex_str.";\n"; + $re_debug and + $code = 'BEGIN{require Data::Dumper;' + .'print(STDERR Data::Dumper->new([$input],["input"])->Indent(0)->Dump,' + .'"\n-- Code --\n",' . pp($code) . ',"----\n")}' . "\n" + . $code . "\n" + . q{print STDERR "----\n",Data::Dumper->new([\@output],["*output"])->Indent(0)->Dump;}; run_code($sample->attr('id'), $code, $text, \&run_code_callback); } @@ -449,7 +450,6 @@ sub run_code_callback { if ( $rv->{out} && $rv->{out}->@* ) { $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 @-! @@ -465,7 +465,6 @@ sub run_code_callback { } } } - $re_debug and say STDERR 'highlights are ',pp(\%hi); my $html=''; my $p=0; my (%active_match,%active_caps); @@ -509,7 +508,16 @@ sub run_code_callback { { $errs = $rv->{err} } $samptxt->text($text); } + my $stdoe = ''; + for my $s (qw/stdout stderr/) { + next unless length $rv->{$s} && $rv->{$s}=~/\S/; + $rv->{$s} =~ s/\A\n+|\n+\z//g; + $stdoe .= "### ".uc($s)." ###\n".$rv->{$s}."\n"; + } + $sample->children('.re_output')->text($stdoe); + unshift @{ $rv->{warns} }, "### Warnings ###" if $rv->{warns}->@*; $sample->children('.re_warns')->text( join "\n", $rv->{warns}->@* ); + $errs = "### Errors ###\n$errs" if $errs=~/\S/; $sample->children('.re_errors')->text($errs); } @@ -586,11 +594,7 @@ my $x = "foo"; # example