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

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

3 files changed, 65 insertions, 34 deletions

diff --git a/lib/Text/Balanced.pm b/lib/Text/Balanced.pm
index bb839a005e..9cfe6bf35a 100644
--- 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 34207df2f3..94699fa860 100644
--- 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 b5d9fe6782..e823e34b0e 100644
--- 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 '->'