Match highlighting fixes and updates

- Zero-length matches weren't being handled correctly
- Non-matching capture groups weren't being handled correctly
- Added capture group names
master
Hauke D 7 years ago
parent d58ec6e086
commit 1aafe2099b

@ -49,10 +49,17 @@ textarea.samp_ta {
} }
.match { .match {
background-color: lightblue; background-color: lightblue;
border: 1px solid blue;
} }
.capture { .capture {
background-color: lightgreen; background-color: lightgreen;
} }
.capture.zlen {
border: 1px solid green;
}
.zlen:hover:after {
content: " ";
}
</style> </style>
<script src="webperl.js"></script> <script src="webperl.js"></script>
@ -69,6 +76,9 @@ use File::Temp qw/tempfile/;
use Data::Dumper (); use Data::Dumper ();
my $jq = js('jQuery'); 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"); $jq->('#perlinfo')->text("perl $^V");
sub sample_init { sub sample_init {
@ -167,9 +177,7 @@ sub update {
for my $samptxt ($jq->('.samptxt')->@*) { for my $samptxt ($jq->('.samptxt')->@*) {
$samptxt = $jq->($samptxt); $samptxt = $jq->($samptxt);
my $text = $samptxt->text; my $text = $samptxt->text;
$re_debug and say STDERR "----- ----- ----- ", $re_debug and say STDERR "----- ----- ----- ",pp($text)," ----- ----- -----";
Data::Dumper->new([$text])->Useqq(1)->Terse(1)->Indent(0)->Dump,
" ----- ----- -----";
push @samps, $text; push @samps, $text;
my @m; my @m;
my $code = $flags=~/g/ my $code = $flags=~/g/
@ -179,19 +187,31 @@ sub update {
if (eval $code) { if (eval $code) {
$samptxt->removeClass('nomatch'); $samptxt->removeClass('nomatch');
my %hi; my %hi;
for my $m (@m) { $re_debug and say STDERR '@-/@+ are ',pp(\@m);
my ($s,$e) = @$m; for my $i (0..$#m) {
$hi{shift @$s}{match}++; my ($s,$e) = $m[$i]->@*;
$hi{$_}{cap}++ for @$s; for my $j (0..$#$e) { # Use @+ to count all capture groups instead of @-!
$hi{$_}{end}++ for @$e; 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 $html='';
my $p=0; my $p=0;
for my $i (sort {$a<=>$b} keys %hi) { for my $i (sort {$a<=>$b} keys %hi) {
$html .= substr($text,$p,$i-$p); $html .= substr($text,$p,$i-$p);
$html .= '</span>' for 1..$hi{$i}{end}//0; $html .= '</span>' x ($hi{$i}{end}//0);
$html .= '<span class="match">' for 1..$hi{$i}{match}//0; $html .= "<span class='zlen match' title='$_'></span>" for @{ $hi{$i}{zlen_match}//[] };
$html .= '<span class="capture">' for 1..$hi{$i}{cap}//0; $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 } } continue { $p=$i }
$html .= substr($text,$p); $html .= substr($text,$p);
$samptxt->html($html); $samptxt->html($html);

Loading…
Cancel
Save