|
45 | 45 | cursor: pointer; |
46 | 46 | } |
47 | 47 | .re_warns { |
| 48 | + clear: both; |
48 | 49 | background-color: rgba(255,255,200,255); |
49 | 50 | } |
50 | | -.nomatch, .re_errors { |
| 51 | +.re_errors { |
51 | 52 | background-color: rgba(255,200,200,255); |
52 | 53 | } |
| 54 | +.nomatch { |
| 55 | + background-color: rgba(200,200,200,255); |
| 56 | +} |
53 | 57 | .match { |
54 | 58 | background-color: lightblue; |
55 | 59 | border: 1px solid blue; |
|
93 | 97 | my $closebtn = $jq->('<div/>', {html=>"🗙",class=>"closebtn", |
94 | 98 | title=>"Delete Sample"}); |
95 | 99 | $closebtn->appendTo($samp); |
| 100 | + $jq->('<pre/>', {class=>'re_warns'})->appendTo($samp); |
| 101 | + $jq->('<pre/>', {class=>'re_errors'})->appendTo($samp); |
96 | 102 | $samp->click(sub { |
97 | 103 | return if $samp_ta->is(':visible'); |
98 | 104 | $samp_ta->height($samptxt->height); |
|
195 | 201 | my $thisurl_ta = $jq->("#thisurl"); |
196 | 202 | my $ta_regex = $jq->("#regex"); |
197 | 203 | my $ta_flags = $jq->("#flags"); |
198 | | -my $errmsgs = $jq->("#errmsgs"); |
199 | 204 | my $warnmsgs = $jq->("#warnmsgs"); |
200 | 205 | $ta_regex->change(\&update); |
201 | 206 | $ta_regex->keyup( \&update); |
|
207 | 212 | $ta_regex->height($ta_regex->[0]->{scrollHeight}); |
208 | 213 | }); |
209 | 214 |
|
| 215 | +sub run_code { |
| 216 | + my ($code,$inp) = @_; |
| 217 | + my @warns; |
| 218 | + my $ok = do { |
| 219 | + local $SIG{__WARN__} = sub { push @warns, shift }; |
| 220 | + package run_code; |
| 221 | + our $input = $inp; |
| 222 | + our @output = (); |
| 223 | + eval "$code;1" }; |
| 224 | + my $err = $ok ? undef : $@||"Unknown error"; |
| 225 | + defined && s/\bat .+? line \d+(?:\.$|,\h)//mg for (@warns,$err); |
| 226 | + chomp(@warns); |
| 227 | + return { warns=>\@warns, $ok ? (out=>\@run_code::output) : (err=>$err) } |
| 228 | +} |
| 229 | + |
210 | 230 | sub update { |
211 | 231 | my $regex = $ta_regex->val; |
212 | 232 | my $flags = $ta_flags->val; |
|
218 | 238 | "NOTE: The empty regex $regex_str requires a workaround with /(?:)/," # https://www.perlmonks.org/?node_id=1221517 |
219 | 239 | ."\n this will be reflected in the debug output"; |
220 | 240 |
|
221 | | - # check regex for syntax errors |
222 | | - my ($warn,$err) = ('',''); |
| 241 | + my $warn = ''; |
223 | 242 | $warn .= "Notice: The empty pattern has special behavior, see perlop!\n" |
224 | 243 | ." Here, a workaround is used so it acts as a true empty pattern.\n" unless length $regex; |
225 | 244 | $warn .= "\\n is recommended over literal newlines\n" if $regex=~/\n/ && $flags!~/x/; |
226 | 245 | $warn .= "\\t is recommended over literal tabs\n" if $regex=~/\t/ && $flags!~/x/; |
227 | | - my $ok = do { |
228 | | - local $SIG{__WARN__} = sub { $warn .= shift }; |
229 | | - eval( $precode.($re_debug?'use re "debug";':'')."''=~$regex_str;1") }; |
230 | | - $ok or $err .= $@||"Unknown error"; |
231 | | - s/\bat .+? line \d+(?:\.$|,\h)//mg for $warn,$err; |
232 | | - $ok or $err .= "Matching aborted!"; |
233 | | - $errmsgs->text($err); |
234 | 246 | $warnmsgs->text($warn); |
235 | | - return if !$ok; |
236 | 247 |
|
237 | 248 | # apply regex to the samples and do highlighting |
238 | 249 | my @samps; |
239 | | - for my $samptxt ($jq->('.samptxt')->@*) { |
240 | | - $samptxt = $jq->($samptxt); |
| 250 | + for my $sample (map {$jq->($_)} $jq->('.sample')->@*) { |
| 251 | + my $samptxt = $sample->children('.samptxt'); |
| 252 | + my $re_warns = $sample->children('.re_warns'); |
| 253 | + my $re_errs = $sample->children('.re_errors'); |
241 | 254 | my $text = $samptxt->text; |
242 | 255 | $re_debug and say STDERR "----- ----- ----- ",pp($text)," ----- ----- -----"; |
243 | 256 | push @samps, $text; |
244 | | - my @m; |
245 | 257 | my $code = $precode . ($re_debug?'use re "debug";':'') |
246 | 258 | . (length($regex)?'':"''=~/(?:)/$flags;") |
247 | | - . ($flags=~/g/ |
248 | | - ? 'push @m,[[@-],[@+]] while $text=~'.$regex_str.'; scalar @m' |
249 | | - : '$text=~'.$regex_str.' and push @m,[[@-],[@+]]; scalar @m'); |
250 | | - if (eval $code) { #TODO Later: maybe merge this with the above error checking? |
| 259 | + . 'push @output,[[@-],[@+]] ' . ($flags=~/g/?'while':'if') . ' $input=~'.$regex_str; |
| 260 | + my $rv = run_code($code, $text); |
| 261 | + $re_warns->text( join "\n", $rv->{warns}->@* ); |
| 262 | + if ( $rv->{out} && $rv->{out}->@* ) { |
| 263 | + $re_errs->text(''); |
251 | 264 | $samptxt->removeClass('nomatch'); |
252 | 265 | my %hi; |
253 | | - $re_debug and say STDERR '@-/@+ are ',pp(\@m); |
254 | | - for my $i (0..$#m) { |
255 | | - my ($s,$e) = $m[$i]->@*; |
| 266 | + $re_debug and say STDERR '@-/@+ are ',pp($rv->{out}); |
| 267 | + for my $i (0..$#{$rv->{out}}) { |
| 268 | + my ($s,$e) = $rv->{out}[$i]->@*; |
256 | 269 | for my $j (0..$#$e) { # Use @+ to count all capture groups instead of @-! |
257 | 270 | next if !defined($$s[$j]) && !defined($$e[$j]); |
258 | 271 | my $name = "Match ".($i+1).($j?" Capture Group $j":""); |
|
280 | 293 | $samptxt->html($html); |
281 | 294 | } |
282 | 295 | else { |
| 296 | + $re_errs->text($rv->{out} ? '' : $rv->{err}); |
| 297 | + $rv->{out} && $samptxt->addClass('nomatch'); |
283 | 298 | $samptxt->text($text); |
284 | | - $samptxt->addClass('nomatch'); |
285 | 299 | } |
286 | 300 | } |
287 | 301 |
|
|
394 | 408 | ><textarea id="flags" rows="1" cols="5" style="height:1.2em" |
395 | 409 | title="Flags for Regular Expression">gi</textarea></div> |
396 | 410 | <pre id="warnmsgs" class="re_warns"></pre> |
397 | | -<pre id="errmsgs" class="re_errors"></pre> |
398 | 411 | </div> |
399 | 412 |
|
400 | 413 | <div class="sample"> |
|
0 commit comments