- Restore two Text::Balanced tests, more comprehensive in bleadperl than

  in CPAN.
- Restore a local bugfix, tested by the above tests.
- Fix a few typos in the POD for Text::Balanced
- Bump version of Text::Balanced

p4raw-id: //depot/perl@29345

diff --git a/lib/Text/Balanced.pm b/lib/Text/Balanced.pm
index a50fb4f..49d4217 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 version; $VERSION = qv('1.99.1');
+use version; $VERSION = qv('1.99.1_1');
 @ISA           = qw ( Exporter );
                     
 %EXPORT_TAGS   = ( ALL => [ qw(
@@ -719,8 +719,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) .
@@ -1128,9 +1127,9 @@ The substring to be extracted must appear at the
 current C<pos> location of the string's variable
 (or at index zero, if no C<pos> position is defined).
 In other words, the C<extract_...> subroutines I<don't>
-extract the first occurance of a substring anywhere
+extract the first occurrence of a substring anywhere
 in a string (like an unanchored regex would). Rather,
-they extract an occurance of the substring appearing
+they extract an occurrence of the substring appearing
 immediately at the current matching position in the
 string (like a C<\G>-anchored regex would).
 
@@ -1396,7 +1395,7 @@ See also: C<"extract_quotelike"> and C<"extract_codeblock">.
 
 C<extract_variable> extracts any valid Perl variable or
 variable-involved expression, including scalars, arrays, hashes, array
-accesses, hash look-ups, method calls through objects, subroutine calles
+accesses, hash look-ups, method calls through objects, subroutine calls
 through subroutine references, etc.
 
 The subroutine takes up to two optional arguments:
@@ -2055,7 +2054,7 @@ If none of the extractor subroutines succeeds, then one
 character is extracted from the start of the text and the extraction
 subroutines reapplied. Characters which are thus removed are accumulated and
 eventually become the next field (unless the fourth argument is true, in which
-case they are disgarded).
+case they are discarded).
 
 For example, the following extracts substrings that are valid Perl variables:
 

diff --git a/lib/Text/Balanced/t/extmul.t b/lib/Text/Balanced/t/extmul.t
index 34207df..98b6272 100644 (file)
--- 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,11 @@ 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 1371a4e..0129cd0 100644 (file)
--- 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 '->'