Rollback two changes in Text::Balanced which cause test failures in the

CPAN and bleadperl version of the tests.  Also, the previous bleadperl
version of one test file is a bit more comprehensive than what was in
CPAN, so it has been completely restored.

p4raw-id: //depot/perl@28125

2 files changed, 56 insertions, 31 deletions

diff --git a/lib/Text/Balanced.pm b/lib/Text/Balanced.pm
index 2c84a5a3ac..383ecf6b55 100644
--- a/lib/Text/Balanced.pm
+++ b/lib/Text/Balanced.pm
@@ -64,7 +64,8 @@ sub _succeed
 	$@ = undef;
 	my ($wantarray,$textref) = splice @_, 0, 2;
 	my ($extrapos, $extralen) = @_>18 ? splice(@_, -2, 2) : (0,0);
-	my ($startlen, $oppos) = $_[5,6];
+	my ($startlen, $oppos) = $_[5];
+        my $oppos = $_[6];
 	my $remainderpos = $_[2];
 	if ($wantarray)
 	{
@@ -728,8 +729,7 @@ sub _match_quotelike($$$$)	# ($textref, $prepat, $allow_raw_match)
 		       );
 	}
 
-	unless ($$textref =~
-    m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<(?=\s*["'A-Za-z_]))}gc)
+	unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc)
 	{
 		_failmsg q{No quotelike operator found after prefix at "} .
 			     substr($$textref, pos($$textref), 20) .
diff --git a/lib/Text/Balanced/t/extqlk.t b/lib/Text/Balanced/t/extqlk.t
index 1371a4ede7..0129cd0ba5 100644
--- a/lib/Text/Balanced/t/extqlk.t
+++ b/lib/Text/Balanced/t/extqlk.t
@@ -14,15 +14,16 @@ 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..95\n"; }
 END {print "not ok 1\n" unless $loaded;}
 use Text::Balanced qw ( extract_quotelike );
 $loaded = 1;
 print "ok 1\n";
 $count=2;
 use vars qw( $DEBUG );
-# $DEBUG=1;
-sub debug { print "\t>>>",@_ if $DEBUG }
+#$DEBUG=1;
+sub debug { print "\t>>>",@_ if $ENV{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[$_]||="<undef>")=~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);
@@ -75,11 +92,16 @@ __DATA__
 <<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
      <<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
 <<"EOHERE"; done()\nline1\nline2\nEOHERE\n and next
+<<`EOHERE`; done()\nline1\nline2\nEOHERE\n and next
 <<'EOHERE'; done()\nline1\n'line2'\nEOHERE\n and next
 <<'EOHERE;'; done()\nline1\nline2\nEOHERE;\n and next
 <<"   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;
@@ -109,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 '->'