Re: [perl #25157] [PATCH] Text-Balanced extract_quotelike fails on certain delims...

Message-ID: <400F2E7F.9090601@math2.org>

Fixes perl #25151, 25154, 25156, 25157, 25158 using jumbo patch
included in perl #25157.

p4raw-id: //depot/perl@25135

diff --git a/lib/Text/Balanced.pm b/lib/Text/Balanced.pm
index bb839a0..9cfe6bf 100644 (file)
--- a/lib/Text/Balanced.pm
+++ b/lib/Text/Balanced.pm
@@ -65,6 +65,7 @@ sub _succeed
        my ($wantarray,$textref) = splice @_, 0, 2;
        my ($extrapos, $extralen) = @_>18 ? splice(@_, -2, 2) : (0,0);
        my ($startlen) = $_[5];
+       my $oppos = $_[6];
        my $remainderpos = $_[2];
        if ($wantarray)
        {
@@ -74,7 +75,7 @@ sub _succeed
                        push @res, substr($$textref,$from,$len);
                }
                if ($extralen) {        # CORRECT FILLET
-                       my $extra = substr($res[0], $extrapos-$startlen, $extralen, "\n");
+                       my $extra = substr($res[0], $extrapos-$oppos, $extralen, "\n");
                        $res[1] = "$extra$res[1]";
                        eval { substr($$textref,$remainderpos,0) = $extra;
                               substr($$textref,$extrapos,$extralen,"\n")} ;
@@ -757,8 +758,8 @@ sub _match_quotelike($$$$)  # ($textref, $prepat, $allow_raw_match)
                }
                my $extrapos = pos($$textref);
                $$textref =~ m{.*\n}gc;
-               $str1pos = pos($$textref);
-               unless ($$textref =~ m{.*?\n(?=$label\n)}gc) {
+               $str1pos = pos($$textref)--;
+               unless ($$textref =~ m{.*?\n(?=\Q$label\E\n)}gc) {
                        _failmsg qq{Missing here doc terminator ('$label') after "} .
                                     substr($$textref, $startpos, 20) .
                                     q{..."},
@@ -767,7 +768,7 @@ sub _match_quotelike($$$$)  # ($textref, $prepat, $allow_raw_match)
                        return;
                }
                $rd1pos = pos($$textref);
-               $$textref =~ m{$label\n}gc;
+               $$textref =~ m{\Q$label\E\n}gc;
                $ld2pos = pos($$textref);
                return (
                        $startpos,      $oppos-$startpos,       # PREFIX
@@ -800,7 +801,7 @@ sub _match_quotelike($$$$)  # ($textref, $prepat, $allow_raw_match)
        if ($ldel1 =~ /[[(<{]/)
        {
                $rdel1 =~ tr/[({</])}>/;
-               _match_bracketed($textref,"",$ldel1,"","",$rdel1)
+               defined(_match_bracketed($textref,"",$ldel1,"","",$rdel1))
                || do { pos $$textref = $startpos; return };
        }
        else
@@ -835,7 +836,7 @@ sub _match_quotelike($$$$)  # ($textref, $prepat, $allow_raw_match)
                if ($ldel2 =~ /[[(<{]/)
                {
                        pos($$textref)--;       # OVERCOME BROKEN LOOKAHEAD 
-                       _match_bracketed($textref,"",$ldel2,"","",$rdel2)
+                       defined(_match_bracketed($textref,"",$ldel2,"","",$rdel2))
                        || do { pos $$textref = $startpos; return };
                }
                else
@@ -938,7 +939,7 @@ sub extract_multiple (;$$$$)        # ($text, $functions_ref, $max_fields, $ignoreunkno
                                if (defined($field) && length($field))
                                {
                                        if (!$igunk) {
-                                               $unkpos = pos $$textref
+                                               $unkpos = $lastpos
                                                        if length($pref) && !defined($unkpos);
                                                if (defined $unkpos)
                                                {

diff --git a/lib/Text/Balanced/t/extmul.t b/lib/Text/Balanced/t/extmul.t
index 34207df..94699fa 100644 (file)
--- a/lib/Text/Balanced/t/extmul.t
+++ b/lib/Text/Balanced/t/extmul.t
@@ -13,7 +13,7 @@ BEGIN {
 # Change 1..1 below to 1..last_test_to_print .
 # (It may become useful if the test is moved to ./t subdirectory.)
 
-BEGIN { $| = 1; print "1..85\n"; }
+BEGIN { $| = 1; print "1..86\n"; }
 END {print "not ok 1\n" unless $loaded;}
 use Text::Balanced qw ( :ALL );
 $loaded = 1;
@@ -316,3 +316,10 @@ expect     [ scalar extract_multiple(undef, [ q/([a-z]),?/ ]) ],
 
 expect [ pos ], [ 0 ];
 expect [ $_ ], [ substr($stdtext3,2) ];
+
+# TEST 86
+
+# Fails in Text-Balanced-1.95 with result ['1 ', '""', '1234']
+$_ = q{ ""1234};
+expect [ extract_multiple(undef, [\&extract_quotelike]) ],
+       [ ' ', '""', '1234' ];

diff --git a/lib/Text/Balanced/t/extqlk.t b/lib/Text/Balanced/t/extqlk.t
index b5d9fe6..e823e34 100644 (file)
--- a/lib/Text/Balanced/t/extqlk.t
+++ b/lib/Text/Balanced/t/extqlk.t
@@ -14,7 +14,7 @@ BEGIN {
 # Change 1..1 below to 1..last_test_to_print .
 # (It may become useful if the test is moved to ./t subdirectory.)
 
-BEGIN { $| = 1; print "1..89\n"; }
+BEGIN { $| = 1; print "1..95\n"; }
 END {print "not ok 1\n" unless $loaded;}
 use Text::Balanced qw ( extract_quotelike );
 $loaded = 1;
@@ -23,6 +23,7 @@ $count=2;
 use vars qw( $DEBUG );
 # $DEBUG=1;
 sub debug { print "\t>>>",@_ if $DEBUG }
+sub esc   { my $x = shift; $x =~ s/\n/\\n/gs; $x }
 
 ######################### End of black magic.
 
@@ -32,36 +33,52 @@ $neg = 0;
 while (defined($str = <DATA>))
 {
        chomp $str;
-       if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
+       if ($str =~ s/\A# USING://)                 { $neg = 0; $cmd = $str; next; }
        elsif ($str =~ /\A# TH[EI]SE? SHOULD FAIL/) { $neg = 1; next; }
-       elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
-       debug "\tUsing: $cmd\n";
-       debug "\t   on: [$str]\n";
+       elsif (!$str || $str =~ /\A#/)              { $neg = 0; next }
+       my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : '';
+       my $tests = 'sl';
        $str =~ s/\\n/\n/g;
        my $orig = $str;
 
-        my @res;
-       eval qq{\@res = $cmd; };
-       debug "\t  got:\n" . join "", map { $res[$_]=~s/\n/\\n/g; "\t\t\t$_: [$res[$_]]\n"} (0..$#res);
-       debug "\t left: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy1 = $str)[0];
-       debug "\t  pos: " . (map { s/\n/\\n/g; "[$_]\n" } my $cpy2 = substr($str,pos($str)))[0] . "...]\n";
-       print "not " if (substr($str,pos($str),1) eq ';')==$neg;
-       print "ok ", $count++;
-       print "\n";
-
-       $str = $orig;
-       debug "\tUsing: scalar $cmd\n";
-       debug "\t   on: [$str]\n";
-       $var = eval $cmd;
-       print " ($@)" if $@ && $DEBUG;
-       $var = "<undef>" unless defined $var;
-       debug "\t scalar got: " . (map { s/\n/\\n/g; "[$_]\n" } $var)[0];
-       debug "\t scalar left: " . (map { s/\n/\\n/g; "[$_]\n" } $str)[0];
-       print "not " if ($str =~ '\A;')==$neg;
-       print "ok ", $count++;
-       print "\n";
+       eval $setup_cmd if $setup_cmd ne ''; 
+       if($tests =~ /l/) {
+               debug "\tUsing: $cmd\n";
+               debug "\t   on: [" . esc($setup_cmd) . "][" . esc($str) . "]\n";
+               my @res;
+               eval qq{\@res = $cmd; };
+               debug "\t  got:\n" . join "", map { "\t\t\t$_: [" . esc($res[$_]) . "]\n"} (0..$#res);
+               debug "\t left: [" . esc($str) . "]\n";
+               debug "\t  pos: [" . esc(substr($str,pos($str))) . "...]\n";
+               print "not " if (substr($str,pos($str),1) eq ';')==$neg;
+               print "ok ", $count++;
+               print "\n";
+       }
+
+       eval $setup_cmd if $setup_cmd ne '';
+       if($tests =~ /s/) {
+               $str = $orig;
+               debug "\tUsing: scalar $cmd\n";
+               debug "\t   on: [" . esc($str) . "]\n";
+               $var = eval $cmd;
+               print " ($@)" if $@ && $DEBUG;
+               $var = "<undef>" unless defined $var;
+               debug "\t scalar got: [" . esc($var) . "]\n";
+               debug "\t scalar left: [" . esc($str) . "]\n";
+               print "not " if ($str =~ '\A;')==$neg;
+               print "ok ", $count++;
+               print "\n";
+       }
 }
 
+# fails in Text::Balanced 1.95
+$_ = qq(s{}{});
+my @z = extract_quotelike();
+print "not " if $z[0] eq '';
+print "ok ", $count++;
+print "\n";
+
+ 
 __DATA__
 
 # USING: extract_quotelike($str);
@@ -81,7 +98,10 @@ __DATA__
 <<"   EOHERE"; done() \nline1\nline2\n   EOHERE\nand next
 <<""; done()\nline1\nline2\n\n and next
 <<; done()\nline1\nline2\n\n and next
-
+# fails in Text::Balanced 1.95
+<<EOHERE;\nEOHERE\n; 
+# fails in Text::Balanced 1.95
+<<"*";\n\n*\n; 
 
 "this is a nested $var[$x] {";
 /a/gci;
@@ -111,6 +131,9 @@ s/'/\\'/g;
 tr/x/y/;
 y/x/y/;
 
+# fails on Text-Balanced-1.95
+{ $tests = 'l'; pos($str)=6 }012345<<E;\n\nE\n
+
 # THESE SHOULD FAIL
 s<$self->{pat}>{$self->{sub}};         # CAN'T HANDLE '>' in '->'
 s-$self->{pap}-$self->{sub}-;          # CAN'T HANDLE '-' in '->'