From: Rafael Garcia-Suarez Date: Wed, 22 Nov 2006 09:56:14 +0000 (+0000) Subject: - Restore two Text::Balanced tests, more comprehensive in bleadperl than X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=aa10195b3aa19bb4f167204cdce8fb75d361ccb8;p=p5sagit%2Fp5-mst-13.2.git - 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 --- 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 location of the string's variable (or at index zero, if no C position is defined). In other words, the C subroutines I -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 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 --- 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 --- 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 = )) { 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[$_]||="")=~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 = "" 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 = "" 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__ <{pat}>{$self->{sub}}; # CAN'T HANDLE '>' in '->' s-$self->{pap}-$self->{sub}-; # CAN'T HANDLE '-' in '->'