Upgrade to Text::Balanced 1.89.
Jarkko Hietaniemi [Tue, 20 Nov 2001 02:58:38 +0000 (02:58 +0000)]
p4raw-id: //depot/perl@13118

lib/Text/Balanced.pm
lib/Text/Balanced/Changes
lib/Text/Balanced/README
lib/Text/Balanced/t/extbrk.t
lib/Text/Balanced/t/extcbk.t
lib/Text/Balanced/t/extdel.t
lib/Text/Balanced/t/extmul.t
lib/Text/Balanced/t/extqlk.t
lib/Text/Balanced/t/exttag.t
lib/Text/Balanced/t/extvar.t
lib/Text/Balanced/t/gentag.t

index b9a33cb..06e4fe1 100644 (file)
@@ -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
index 5b34b73..2b42f94 100644 (file)
@@ -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
index feba188..ef2f376 100755 (executable)
@@ -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
 
 
 ==============================================================================
index a36025d..e2763e8 100644 (file)
@@ -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'
 
index 10f9741..69957ed 100644 (file)
@@ -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'
 
index c5ca88e..6db547f 100644 (file)
@@ -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'
 
index 46addcc..34207df 100644 (file)
@@ -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) ];
index 217d7d1..b5d9fe6 100644 (file)
@@ -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'
index 764e790..79a4e2e 100644 (file)
@@ -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'
 
index 93bd22b..f8a46bb 100644 (file)
@@ -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->;
index 4e68b41..ae94c54 100644 (file)
@@ -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'