Upgrade to Text::Balanced 1.89.

p4raw-id: //depot/perl@13118

11 files changed, 183 insertions, 47 deletions

diff --git a/lib/Text/Balanced.pm b/lib/Text/Balanced.pm
index b9a33cb01f..06e4fe1003 100644
--- a/lib/Text/Balanced.pm
+++ b/lib/Text/Balanced.pm
@@ -10,7 +10,7 @@ use Exporter;
 use SelfLoader;
 use vars qw { $VERSION @ISA %EXPORT_TAGS };
 
-$VERSION = '1.86';
+$VERSION = '1.89';
 @ISA		= qw ( Exporter );
 		     
 %EXPORT_TAGS	= ( ALL => [ qw(
@@ -429,6 +429,9 @@ sub extract_variable (;$$)
 
 sub _match_variable($$)
 {
+#  $#
+#  $^
+#  $$
 	my ($textref, $pre) = @_;
 	my $startpos = pos($$textref) = pos($$textref)||0;
 	unless ($$textref =~ m/\G($pre)/gc)
@@ -437,19 +440,24 @@ sub _match_variable($$)
 		return;
 	}
 	my $varpos = pos($$textref);
-	unless ($$textref =~ m/\G(\$#?|[*\@\%]|\\&)+/gc)
+        unless ($$textref =~ m{\G\$\s*(\d+|[][&`'+*./|,";%=~:?!\@<>()-]|\^[a-z]?)}gci)
 	{
+	    unless ($$textref =~ m/\G((\$#?|[*\@\%]|\\&)+)/gc)
+	    {
 		_failmsg "Did not find leading dereferencer", pos $$textref;
 		pos $$textref = $startpos;
 		return;
-	}
+	    }
+	    my $deref = $1;
 
-	unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci
-		or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0))
-	{
+	    unless ($$textref =~ m/\G\s*(?:::|')?(?:[_a-z]\w*(?:::|'))*[_a-z]\w*/gci
+	    	or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0)
+		or $deref eq '$#' or $deref eq '$$' )
+	    {
 		_failmsg "Bad identifier after dereferencer", pos $$textref;
 		pos $$textref = $startpos;
 		return;
+	    }
 	}
 
 	while (1)
@@ -854,13 +862,13 @@ sub extract_multiple (;$$$$)	# ($text, $functions_ref, $max_fields, $ignoreunkno
 	my ($lastpos, $firstpos);
 	my @fields = ();
 
-	for ($$textref)
+	#for ($$textref)
 	{
 		my @func = defined $_[1] ? @{$_[1]} : @{$def_func};
 		my $max  = defined $_[2] && $_[2]>0 ? $_[2] : 1_000_000_000;
 		my $igunk = $_[3];
 
-		pos ||= 0;
+		pos $$textref ||= 0;
 
 		unless (wantarray)
 		{
@@ -888,51 +896,57 @@ sub extract_multiple (;$$$$)	# ($text, $functions_ref, $max_fields, $ignoreunkno
 			}
 		}
 
-		FIELD: while (pos() < length())
+		FIELD: while (pos($$textref) < length($$textref))
 		{
 			my $field;
+			my @bits;
 			foreach my $i ( 0..$#func )
 			{
+				my $pref;
 				$func = $func[$i];
 				$class = $class[$i];
-				$lastpos = pos;
+				$lastpos = pos $$textref;
 				if (ref($func) eq 'CODE')
-					{ ($field) = $func->($_) }
+					{ ($field,undef,$pref) = @bits = $func->($$textref) }
 				elsif (ref($func) eq 'Text::Balanced::Extractor')
-					{ $field = $func->extract($_) }
-				elsif( m/\G$func/gc )
-					{ $field = defined($1) ? $1 : $& }
-
+					{ @bits = $field = $func->extract($$textref) }
+				elsif( $$textref =~ m/\G$func/gc )
+					{ @bits = $field = defined($1) ? $1 : $& }
+				$pref ||= "";
 				if (defined($field) && length($field))
 				{
-					if (defined($unkpos) && !$igunk)
-					{
-						push @fields, substr($_, $unkpos, $lastpos-$unkpos);
-						$firstpos = $unkpos unless defined $firstpos;
-						undef $unkpos;
-						last FIELD if @fields == $max;
+					if (!$igunk) {
+						$unkpos = pos $$textref
+							if length($pref) && !defined($unkpos);
+						if (defined $unkpos)
+						{
+							push @fields, substr($$textref, $unkpos, $lastpos-$unkpos).$pref;
+							$firstpos = $unkpos unless defined $firstpos;
+							undef $unkpos;
+							last FIELD if @fields == $max;
+						}
 					}
-					push @fields, $class 
-						? bless(\$field, $class)
+					push @fields, $class
+						? bless (\$field, $class)
 						: $field;
 					$firstpos = $lastpos unless defined $firstpos;
-					$lastpos = pos;
+					$lastpos = pos $$textref;
 					last FIELD if @fields == $max;
 					next FIELD;
 				}
 			}
-			if (/\G(.)/gcs)
+			if ($$textref =~ /\G(.)/gcs)
 			{
-				$unkpos = pos()-1
+				$unkpos = pos($$textref)-1
 					unless $igunk || defined $unkpos;
 			}
 		}
 		
 		if (defined $unkpos)
 		{
-			push @fields, substr($_, $unkpos);
+			push @fields, substr($$textref, $unkpos);
 			$firstpos = $unkpos unless defined $firstpos;
-			$lastpos = length;
+			$lastpos = length $$textref;
 		}
 		last;
 	}
@@ -1925,13 +1939,18 @@ such substrings are skipped. Otherwise, they are returned.
 =back
 
 The extraction process works by applying each extractor in
-sequence to the text string. If the extractor is a subroutine it
-is called in a list
-context and is expected to return a list of a single element, namely
-the extracted text.
-Note that the value returned by an extractor subroutine need not bear any
-relationship to the corresponding substring of the original text (see
-examples below).
+sequence to the text string.
+
+If the extractor is a subroutine it is called in a list context and is
+expected to return a list of a single element, namely the extracted
+text. It may optionally also return two further arguments: a string
+representing the text left after extraction (like $' for a pattern
+match), and a string representing any prefix skipped before the
+extraction (like $` in a pattern match). Note that this is designed
+to facilitate the use of other Text::Balanced subroutines with
+C<extract_multiple>. Note too that the value returned by an extractor
+subroutine need not bear any relationship to the corresponding substring
+of the original text (see examples below).
 
 If the extractor is a precompiled regular expression or a string,
 it is matched against the text in a scalar context with a leading
diff --git a/lib/Text/Balanced/Changes b/lib/Text/Balanced/Changes
index 5b34b73abb..2b42f94402 100644
--- a/lib/Text/Balanced/Changes
+++ b/lib/Text/Balanced/Changes
@@ -246,3 +246,18 @@ Revision history for Perl extension Text::Balanced.
 	- Consolidated POD in .pm file
 
 	- renamed tests to let DOS cope with them
+
+
+1.87	Thu Nov 15 21:25:35 2001
+
+	- Made extract_multiple aware of skipped prefixes returned
+	  by subroutine extractors (such as extract_quotelike, etc.)
+
+	- Made extract_variable aware of punctuation variables
+
+	- Corified tests
+
+
+1.89	Sun Nov 18 22:49:50 2001
+
+	- Fixed extvar.t tests
diff --git a/lib/Text/Balanced/README b/lib/Text/Balanced/README
index feba188b38..ef2f376fa4 100755
--- a/lib/Text/Balanced/README
+++ b/lib/Text/Balanced/README
@@ -1,5 +1,5 @@
 ==============================================================================
-                  Release of version 1.86 of Text::Balanced
+                  Release of version 1.89 of Text::Balanced
 ==============================================================================
 
 
@@ -66,14 +66,10 @@ COPYRIGHT
 
 ==============================================================================
 
-CHANGES IN VERSION 1.86
+CHANGES IN VERSION 1.89
 
 
-	- Revised licence for inclusion in core distribution
-
-	- Consolidated POD in .pm file
-
-	- renamed tests to let DOS cope with them
+	- Fixed extvar.t tests
 
 
 ==============================================================================
diff --git a/lib/Text/Balanced/t/extbrk.t b/lib/Text/Balanced/t/extbrk.t
index a36025ddb0..e2763e83ae 100644
--- a/lib/Text/Balanced/t/extbrk.t
+++ b/lib/Text/Balanced/t/extbrk.t
@@ -1,3 +1,10 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
 # Before `make install' is performed this script should be runnable with
 # `make test'. After `make install' it should work as `perl test.pl'
 
diff --git a/lib/Text/Balanced/t/extcbk.t b/lib/Text/Balanced/t/extcbk.t
index 10f974187b..69957ed758 100644
--- a/lib/Text/Balanced/t/extcbk.t
+++ b/lib/Text/Balanced/t/extcbk.t
@@ -1,3 +1,10 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
 # Before `make install' is performed this script should be runnable with
 # `make test'. After `make install' it should work as `perl test.pl'
 
diff --git a/lib/Text/Balanced/t/extdel.t b/lib/Text/Balanced/t/extdel.t
index c5ca88eebf..6db547f43a 100644
--- a/lib/Text/Balanced/t/extdel.t
+++ b/lib/Text/Balanced/t/extdel.t
@@ -1,3 +1,10 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
 # Before `make install' is performed this script should be runnable with
 # `make test'. After `make install' it should work as `perl test.pl'
 
diff --git a/lib/Text/Balanced/t/extmul.t b/lib/Text/Balanced/t/extmul.t
index 46addcc8b4..34207df2f3 100644
--- a/lib/Text/Balanced/t/extmul.t
+++ b/lib/Text/Balanced/t/extmul.t
@@ -1,3 +1,10 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
 # Before `make install' is performed this script should be runnable with
 # `make test'. After `make install' it should work as `perl test.pl'
 
@@ -172,7 +179,7 @@ expect [ $text ], [ substr($stdtext2,4) ];
 # TESTS 38-40
 $text = $stdtext2;
 expect	[ extract_multiple($text,[\&extract_bracketed]) ],
-	[ substr($stdtext2,0,15), substr($stdtext2,16,7), substr($stdtext2,23) ];
+	[ substr($stdtext2,0,16), substr($stdtext2,16,7), substr($stdtext2,23) ];
 
 expect [ pos $text], [ 24 ];
 expect [ $text ], [ $stdtext2 ];
@@ -180,7 +187,7 @@ expect [ $text ], [ $stdtext2 ];
 # TESTS 41-43
 $text = $stdtext2;
 expect	[ scalar extract_multiple($text,[\&extract_bracketed]) ],
-	[ substr($stdtext2,0,15) ];
+	[ substr($stdtext2,0,16) ];
 
 expect [ pos $text], [ 0 ];
 expect [ $text ], [ substr($stdtext2,15) ];
@@ -206,7 +213,7 @@ expect [ $text ], [ substr($stdtext2,4) ];
 # TESTS 50-52
 $text = $stdtext2;
 expect	[ extract_multiple($text,[\&extract_quotelike]) ],
-	[ substr($stdtext2,0,6), substr($stdtext2,7,5), substr($stdtext2,12) ];
+	[ substr($stdtext2,0,7), substr($stdtext2,7,5), substr($stdtext2,12) ];
 
 expect [ pos $text], [ length($text) ];
 expect [ $text ], [ $stdtext2 ];
@@ -214,7 +221,7 @@ expect [ $text ], [ $stdtext2 ];
 # TESTS 53-55
 $text = $stdtext2;
 expect	[ scalar extract_multiple($text,[\&extract_quotelike]) ],
-	[ substr($stdtext2,0,6) ];
+	[ substr($stdtext2,0,7) ];
 
 expect [ pos $text], [ 0 ];
 expect [ $text ], [ substr($stdtext2,6) ];
diff --git a/lib/Text/Balanced/t/extqlk.t b/lib/Text/Balanced/t/extqlk.t
index 217d7d1fd3..b5d9fe6782 100644
--- a/lib/Text/Balanced/t/extqlk.t
+++ b/lib/Text/Balanced/t/extqlk.t
@@ -1,3 +1,10 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
 #! /usr/local/bin/perl -ws
 # Before `make install' is performed this script should be runnable with
 # `make test'. After `make install' it should work as `perl test.pl'
diff --git a/lib/Text/Balanced/t/exttag.t b/lib/Text/Balanced/t/exttag.t
index 764e7906bb..79a4e2e793 100644
--- a/lib/Text/Balanced/t/exttag.t
+++ b/lib/Text/Balanced/t/exttag.t
@@ -1,3 +1,10 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
 # Before `make install' is performed this script should be runnable with
 # `make test'. After `make install' it should work as `perl test.pl'
 
diff --git a/lib/Text/Balanced/t/extvar.t b/lib/Text/Balanced/t/extvar.t
index 93bd22b41c..f8a46bb4fa 100644
--- a/lib/Text/Balanced/t/extvar.t
+++ b/lib/Text/Balanced/t/extvar.t
@@ -1,3 +1,10 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
 # Before `make install' is performed this script should be runnable with
 # `make test'. After `make install' it should work as `perl test.pl'
 
@@ -6,7 +13,7 @@
 # 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..81\n"; }
+BEGIN { $| = 1; print "1..181\n"; }
 END {print "not ok 1\n" unless $loaded;}
 use Text::Balanced qw ( extract_variable );
 $loaded = 1;
@@ -58,6 +65,7 @@ $a->;
 $a (1..3) { print $a };
 
 # USING: extract_variable($str);
+$obj->nextval;
 *var;
 *$var;
 *{var};
@@ -91,6 +99,55 @@ $#_;
 $#array;
 $#{array};
 $var[$#var];
+$1;
+$11;
+$&;
+$`;
+$';
+$+;
+$*;
+$.;
+$/;
+$|;
+$,;
+$";
+$;;
+$#;
+$%;
+$=;
+$-;
+$~;
+$^;
+$:;
+$^L;
+$^A;
+$?;
+$!;
+$^E;
+$@;
+$$;
+$<;
+$>;
+$(;
+$);
+$[;
+$];
+$^C;
+$^D;
+$^F;
+$^H;
+$^I;
+$^M;
+$^O;
+$^P;
+$^R;
+$^S;
+$^T;
+$^V;
+$^W;
+${^WARNING_BITS};
+${^WIDE_SYSTEM_CALLS};
+$^X;
 
 # THESE SHOULD FAIL
 $a->;
diff --git a/lib/Text/Balanced/t/gentag.t b/lib/Text/Balanced/t/gentag.t
index 4e68b4117a..ae94c54567 100644
--- a/lib/Text/Balanced/t/gentag.t
+++ b/lib/Text/Balanced/t/gentag.t
@@ -1,3 +1,10 @@
+BEGIN {
+    if ($ENV{PERL_CORE}) {
+        chdir('t') if -d 't';
+        @INC = qw(../lib);
+    }
+}
+
 # Before `make install' is performed this script should be runnable with
 # `make test'. After `make install' it should work as `perl test.pl'