diff options
Diffstat (limited to 'perltest')
| -rwxr-xr-x | perltest | 90 |
1 files changed, 58 insertions, 32 deletions
@@ -53,7 +53,6 @@ for (;;) $pattern = $_; - $delimiter = substr($_, 0, 1); while ($pattern !~ /^\s*(.).*\1/s) { printf " > " if $infile eq "STDIN"; @@ -65,6 +64,11 @@ for (;;) chomp($pattern); $pattern =~ s/\s+$//; + # The private /+ modifier means "print $' afterwards". We use it + # only on the end of patterns to make it easy to chop off here. + + $showrest = ($pattern =~ s/\+(?=[a-z]*$)//); + # Check that the pattern is valid eval "\$_ =~ ${pattern}"; @@ -74,6 +78,20 @@ for (;;) next NEXT_RE; } + # If the /g modifier is present, we want to put a loop round the matching; + # otherwise just a single "if". + + $cmd = ($pattern =~ /g[a-z]*$/)? "while" : "if"; + + # If the pattern is actually the null string, Perl uses the most recently + # executed (and successfully compiled) regex is used instead. This is a + # nasty trap for the unwary! The PCRE test suite does contain null strings + # in places - if they are allowed through here all sorts of weird and + # unexpected effects happen. To avoid this, we replace such patterns with + # a non-null pattern that has the same effect. + + $pattern = "/(?#)/$2" if ($pattern =~ /^(.)\1(.*)$/); + # Read data lines and test them for (;;) @@ -88,51 +106,59 @@ for (;;) last if ($_ eq ""); - $_ = eval "\"$_\""; # To get escapes processed - - $ok = 0; - eval "if (\$_ =~ ${pattern}) {" . - "\$z = \$&;" . - "\$a = \$1;" . - "\$b = \$2;" . - "\$c = \$3;" . - "\$d = \$4;" . - "\$e = \$5;" . - "\$f = \$6;" . - "\$g = \$7;" . - "\$h = \$8;" . - "\$i = \$9;" . - "\$j = \$10;" . - "\$k = \$11;" . - "\$l = \$12;" . - "\$m = \$13;" . - "\$n = \$14;" . - "\$o = \$15;" . - "\$p = \$16;" . - "\$ok = 1; }"; + $x = eval "\"$_\""; # To get escapes processed + + # Empty array for holding results, then do the matching. + + @subs = (); + + eval "${cmd} (\$x =~ ${pattern}) {" . + "push \@subs,\$&;" . + "push \@subs,\$1;" . + "push \@subs,\$2;" . + "push \@subs,\$3;" . + "push \@subs,\$4;" . + "push \@subs,\$5;" . + "push \@subs,\$6;" . + "push \@subs,\$7;" . + "push \@subs,\$8;" . + "push \@subs,\$9;" . + "push \@subs,\$10;" . + "push \@subs,\$11;" . + "push \@subs,\$12;" . + "push \@subs,\$13;" . + "push \@subs,\$14;" . + "push \@subs,\$15;" . + "push \@subs,\$16;" . + "push \@subs,\$'; }"; if ($@) { printf $outfile "Error: $@\n"; next NEXT_RE; } - elsif (!$ok) + elsif (scalar(@subs) == 0) { printf $outfile "No match\n"; } else { - @subs = ($z,$a,$b,$c,$d,$e,$f,$g,$h,$i,$j,$k,$l,$m,$n,$o,$p); - $last_printed = 0; - for ($i = 0; $i <= 17; $i++) + while (scalar(@subs) != 0) { - if ($i == 0 || defined $subs[$i]) + printf $outfile (" 0: %s\n", &pchars($subs[0])); + printf $outfile (" 0+ %s\n", &pchars($subs[17])) if $showrest; + $last_printed = 0; + for ($i = 1; $i <= 16; $i++) { - while ($last_printed++ < $i-1) - { printf $outfile ("%2d: <unset>\n", $last_printed); } - printf $outfile ("%2d: %s\n", $i, &pchars($subs[$i])); - $last_printed = $i; + if (defined $subs[$i]) + { + while ($last_printed++ < $i-1) + { printf $outfile ("%2d: <unset>\n", $last_printed); } + printf $outfile ("%2d: %s\n", $i, &pchars($subs[$i])); + $last_printed = $i; + } } + splice(@subs, 0, 18); } } } |