Upgrade to Text::Balanced 1.89.

p4raw-id: //depot/perl@13118

diff --git a/lib/Text/Balanced.pm b/lib/Text/Balanced.pm
index b9a33cb..06e4fe1 100644 (file)
--- 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 };
 
 use SelfLoader;
 use vars qw { $VERSION @ISA %EXPORT_TAGS };
 

-$VERSION = '1.86';
+$VERSION = '1.89';

 @ISA           = qw ( Exporter );
                     
 %EXPORT_TAGS   = ( ALL => [ qw(
 @ISA           = qw ( Exporter );
                     
 %EXPORT_TAGS   = ( ALL => [ qw(


@@ -429,6 +429,9 @@ sub extract_variable (;$$)
 
 sub _match_variable($$)
 {
 
 sub _match_variable($$)
 {

+#  $#
+#  $^
+#  $$

        my ($textref, $pre) = @_;
        my $startpos = pos($$textref) = pos($$textref)||0;
        unless ($$textref =~ m/\G($pre)/gc)
        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);
                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;
                _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;
                _failmsg "Bad identifier after dereferencer", pos $$textref;
                pos $$textref = $startpos;
                return;

+           }

        }
 
        while (1)
        }
 
        while (1)


@@ -854,13 +862,13 @@ sub extract_multiple (;$$$$)      # ($text, $functions_ref, $max_fields, $ignoreunkno
        my ($lastpos, $firstpos);
        my @fields = ();
 
        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];
 
        {
                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)
                {
 
                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 $field;

+                       my @bits;

                        foreach my $i ( 0..$#func )
                        {
                        foreach my $i ( 0..$#func )
                        {

+                               my $pref;

                                $func = $func[$i];
                                $class = $class[$i];
                                $func = $func[$i];
                                $class = $class[$i];

-                               $lastpos = pos;
+                               $lastpos = pos $$textref;

                                if (ref($func) eq 'CODE')
                                if (ref($func) eq 'CODE')

-                                       { ($field) = $func->($_) }
+                                       { ($field,undef,$pref) = @bits = $func->($$textref) }

                                elsif (ref($func) eq 'Text::Balanced::Extractor')
                                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($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;
                                                : $field;
                                        $firstpos = $lastpos unless defined $firstpos;

-                                       $lastpos = pos;
+                                       $lastpos = pos $$textref;

                                        last FIELD if @fields == $max;
                                        next FIELD;
                                }
                        }
                                        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)
                {
                                        unless $igunk || defined $unkpos;
                        }
                }
                
                if (defined $unkpos)
                {

-                       push @fields, substr($_, $unkpos);
+                       push @fields, substr($$textref, $unkpos);

                        $firstpos = $unkpos unless defined $firstpos;
                        $firstpos = $unkpos unless defined $firstpos;

-                       $lastpos = length;
+                       $lastpos = length $$textref;

                }
                last;
        }
                }
                last;
        }


@@ -1925,13 +1939,18 @@ such substrings are skipped. Otherwise, they are returned.
 =back
 
 The extraction process works by applying each extractor in
 =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
 
 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 5b34b73..2b42f94 100644 (file)
--- 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
        - 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 feba188..ef2f376 100755 (executable)
--- 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 a36025d..e2763e8 100644 (file)
--- 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'
 
 # 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 10f9741..69957ed 100644 (file)
--- 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'
 
 # 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 c5ca88e..6db547f 100644 (file)
--- 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'
 
 # 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 46addcc..34207df 100644 (file)
--- 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'
 
 # 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]) ],
 # 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 ];
 
 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]) ],
 # 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) ];
 
 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]) ],
 # 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 ];
 
 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]) ],
 # 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) ];
 
 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 217d7d1..b5d9fe6 100644 (file)
--- 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'
 #! /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 764e790..79a4e2e 100644 (file)
--- 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'
 
 # 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 93bd22b..f8a46bb 100644 (file)
--- 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'
 
 # 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.)
 
 # 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;
 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);
 $a (1..3) { print $a };
 
 # USING: extract_variable($str);

+$obj->nextval;

 *var;
 *$var;
 *{var};
 *var;
 *$var;
 *{var};


@@ -91,6 +99,55 @@ $#_;
 $#array;
 $#{array};
 $var[$#var];
 $#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->;
 
 # THESE SHOULD FAIL
 $a->;

diff --git a/lib/Text/Balanced/t/gentag.t b/lib/Text/Balanced/t/gentag.t
index 4e68b41..ae94c54 100644 (file)
--- 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'
 
 # Before `make install' is performed this script should be runnable with
 # `make test'. After `make install' it should work as `perl test.pl'