开源软件构建与测试

_service:tar_scm:perl-Text-Balanced.spec Changed

_service Changed

_service:tar_scm:Text-Balanced-2.04.tar.gz/Changes -> _service:tar_scm:Text-Balanced-2.06.tar.gz/Changes Changed

@@ -1,5 +1,56 @@
 Revision history for Perl distribution Text-Balanced.
 
+2.06 2022-06-05
+
+    - Released with no further code changes.
+
+2.05_01 2022-05-29
+
+    - Fix direct use of _match_codeblock by e.g. Switch.  mohawk2, CPAN
+      RT#142923
+
+    - Fix resetting of whether "/" or "?" allowed to open regex.  mohawk2, CPAN
+      RT#142922
+
+    - Fix false negative on /.../ regex after "and".  mohawk2, GH#7
+
+2.05 2022-05-22
+
+    - Released with no further code changes.
+
+2.04_02 2022-03-09
+
+    - Fix missed case of spotting expression ending ")" or "".  mohawk2
+
+    - Fix too-loosely allowing ?...? as RE (often actually conditional op).
+      mohawk2
+
+2.04_01 2022-03-05
+
+    - Performance optimizations.  mohawk2, PR#5
+
+    - Fix "<<=" being seen as heredoc, misparsing of "y=>".  mohawk2, PR#6
+
+    - Update documentation to clarify extract_tagged() takes regexes.  Jay
+      Hannah, GH#3
+
+    - Modernize tests.  mohawk2, GH#2
+
+    - Fix extract_variable() not recognising ${var} end of string.  Ed J, CPAN
+      RT#70007
+
+    - Fix string-comparing $@ causing exception.  Ed J, CPAN RT#74994)
+
+    - Update documentation to correct CSV example.  djerius@cpan.org, CPAN
+      RT#140408
+
+    - Fix extract_codeblock() being confused by //.  Ed J, CPAN RT#78313
+
+    - Improve here-doc detection.  Ed J, CPAN RT#74714
+
+    - Fix extract_multiple() to track whether to allow /.../ as quotelike.
+      Ed J, CPAN RT#5722
+
 2.04 2020-12-11
 
     - Fixed INSTALLDIRS to account for the @INC reordering change in Perl 5.12.

_service:tar_scm:Text-Balanced-2.04.tar.gz/META.json -> _service:tar_scm:Text-Balanced-2.06.tar.gz/META.json Changed

_service:tar_scm:Text-Balanced-2.04.tar.gz/META.yml -> _service:tar_scm:Text-Balanced-2.06.tar.gz/META.yml Changed

_service:tar_scm:Text-Balanced-2.04.tar.gz/Makefile.PL -> _service:tar_scm:Text-Balanced-2.06.tar.gz/Makefile.PL Changed

_service:tar_scm:Text-Balanced-2.04.tar.gz/README -> _service:tar_scm:Text-Balanced-2.06.tar.gz/README Changed

_service:tar_scm:Text-Balanced-2.04.tar.gz/lib/Text/Balanced.pm -> _service:tar_scm:Text-Balanced-2.06.tar.gz/lib/Text/Balanced.pm Changed

@@ -1,6 +1,7 @@
 # Copyright (C) 1997-2001 Damian Conway.  All rights reserved.
 # Copyright (C) 2009 Adam Kennedy.
-# Copyright (C) 2015 Steve Hay.  All rights reserved.
+# Copyright (C) 2015, 2022 Steve Hay and other contributors.  All rights
+# reserved.
 
 # This module is free software; you can redistribute it and/or modify it under
 # the same terms as Perl itself, i.e. under the terms of either the GNU General
@@ -17,7 +18,7 @@
 
 use vars qw { $VERSION @ISA %EXPORT_TAGS };
 BEGIN {
-    $VERSION     = '2.04';
+    $VERSION     = '2.06';
     @ISA         = 'Exporter';
     %EXPORT_TAGS = (
         ALL =>  qw{
@@ -37,14 +38,22 @@
 
 Exporter::export_ok_tags('ALL');
 
-## no critic (Subroutines::ProhibitSubroutinePrototypes)
-
-# PROTOTYPES
-
-sub _match_bracketed($$$$$$);
-sub _match_variable($$);
-sub _match_codeblock($$$$$$$);
-sub _match_quotelike($$$$);
+our $RE_PREREGEX_PAT = qr#(
+    !=~
+    | split|grep|map
+    | not|and|or|xor
+)#x;
+our $RE_EXPR_PAT = qr#(
+    (?:\*\*|&&|\|\||<<|>>|//|-+*x%^&|.)=?
+    | /(?:^/)
+    | =(?!>)
+    | return
+    | \(\
+)#x;
+our $RE_NUM = qr/\s*+\-.0-9+\-.0-9e*/i; # numerical constant
+
+our %ref2slashvalid; # is quotelike /.../ pattern valid here for given textref?
+our %ref2qmarkvalid; # is quotelike ?...? pattern valid here for given textref?
 
 # HANDLE RETURN VALUES IN VARIOUS CONTEXTS
 
@@ -99,6 +108,7 @@
 }
 
 # BUILD A PATTERN MATCHING A SIMPLE DELIMITED STRING
+## no critic (Subroutines::ProhibitSubroutinePrototypes)
 
 sub gen_delimited_pat($;$)  # ($delimiters;$escapes)
 {
@@ -132,6 +142,7 @@
 sub extract_delimited (;$$$$)
 {
     my $textref = defined $_0 ? \$_0 : \$_;
+    $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset
     my $wantarray = wantarray;
     my $del  = defined $_1 ? $_1 : qq{\'\"\`};
     my $pre  = defined $_2 ? $_2 : '\s*';
@@ -149,33 +160,45 @@
                     $startpos, $prelen;                         # PREFIX
 }
 
-sub extract_bracketed (;$$$)
-{
-    my $textref = defined $_0 ? \$_0 : \$_;
-    my $ldel = defined $_1 ? $_1 : '{(<';
-    my $pre  = defined $_2 ? $_2 : '\s*';
-    my $wantarray = wantarray;
+my %eb_delim_cache;
+sub _eb_delims {
+    my ($ldel_orig) = @_;
+    return @{ $eb_delim_cache{$ldel_orig} } if $eb_delim_cache{$ldel_orig};
     my $qdel = "";
     my $quotelike;
+    my $ldel = $ldel_orig;
     $ldel =~ s/'//g and $qdel .= q{'};
     $ldel =~ s/"//g and $qdel .= q{"};
     $ldel =~ s/`//g and $qdel .= q{`};
     $ldel =~ s/q//g and $quotelike = 1;
     $ldel =~ tr/(){}<>\0-\377/(({{<</ds;
     my $rdel = $ldel;
-    unless ($rdel =~ tr/({</)}>/)
+    return @{ $eb_delim_cache{$ldel_orig} =  } unless $rdel =~ tr/({</)}>/;
+    my $posbug = pos;
+    $ldel = join('|', map { quotemeta $_ } split('', $ldel));
+    $rdel = join('|', map { quotemeta $_ } split('', $rdel));
+    pos = $posbug;
+    @{ $eb_delim_cache{$ldel_orig} = 
+        qr/\G($ldel)/, $qdel && qr/\G($qdel)/, $quotelike, qr/\G($rdel)/
+     };
+}
+sub extract_bracketed (;$$$)
+{
+    my $textref = defined $_0 ? \$_0 : \$_;
+    $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset
+    my $ldel = defined $_1 ? $_1 : '{(<';
+    my $pre  = defined $_2 ? qr/\G$_2/ : qr/\G\s*/;
+    my $wantarray = wantarray;
+    my @ret = _eb_delims($ldel);
+    unless (@ret)
     {
         return _fail $wantarray, $textref,
                      "Did not find a suitable bracket in delimiter: \"$_1\"",
                      0;
     }
-    my $posbug = pos;
-    $ldel = join('|', map { quotemeta $_ } split('', $ldel));
-    $rdel = join('|', map { quotemeta $_ } split('', $rdel));
-    pos = $posbug;
 
     my $startpos = pos $$textref || 0;
-    my @match = _match_bracketed($textref,$pre, $ldel, $qdel, $quotelike, $rdel);
+    my @match = _match_bracketed($textref, $pre, @ret);
 
     return _fail ($wantarray, $textref) unless @match;
 
@@ -186,11 +209,11 @@
                     );
 }
 
-sub _match_bracketed($$$$$$)    # $textref, $pre, $ldel, $qdel, $quotelike, $rdel
+sub _match_bracketed    # $textref, $pre, $ldel, $qdel, $quotelike, $rdel
 {
     my ($textref, $pre, $ldel, $qdel, $quotelike, $rdel) = @_;
     my ($startpos, $ldelpos, $endpos) = (pos $$textref = pos $$textref||0);
-    unless ($$textref =~ m/\G$pre/gc)
+    unless ($$textref =~ m/$pre/gc)
     {
         _failmsg "Did not find prefix: /$pre/", $startpos;
         return;
@@ -198,7 +221,7 @@
 
     $ldelpos = pos $$textref;
 
-    unless ($$textref =~ m/\G($ldel)/gc)
+    unless ($$textref =~ m/$ldel/gc)
     {
         _failmsg "Did not find opening bracket after prefix: \"$pre\"",
                  pos $$textref;
@@ -212,11 +235,11 @@
     {
         next if $$textref =~ m/\G\\./gcs;
 
-        if ($$textref =~ m/\G($ldel)/gc)
+        if ($$textref =~ m/$ldel/gc)
         {
             push @nesting, $1;
         }
-        elsif ($$textref =~ m/\G($rdel)/gc)
+        elsif ($$textref =~ m/$rdel/gc)
         {
             my ($found, $brackettype) = ($1, $1);
             if ($#nesting < 0)
@@ -237,7 +260,7 @@
             }
             last if $#nesting < 0;
         }
-        elsif ($qdel && $$textref =~ m/\G($qdel)/gc)
+        elsif ($qdel && $$textref =~ m/$qdel/gc)
         {
             $$textref =~ m/\G^\\$1*(?:\\.^\\$1*)*(\Q$1\E)/gsc and next;
             _failmsg "Unmatched embedded quote ($1)",
@@ -245,8 +268,9 @@
             pos $$textref = $startpos;
             return;
         }
-        elsif ($quotelike && _match_quotelike($textref,"",1,0))
+        elsif ($quotelike && _match_quotelike($textref,qr/\G()/,$ref2slashvalid{$textref},$ref2qmarkvalid{$textref}))
         {
+            $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 1; # back-compat
             next;
         }
 
@@ -281,12 +305,14 @@
 
 my $XMLNAME = q{a-zA-Z_:a-zA-Z0-9_:.-*};
 
+my $et_default_ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|^>)*>';
 sub extract_tagged (;$$$$$) # ($text, $opentag, $closetag, $pre, \%options)
 {
     my $textref = defined $_0 ? \$_0 : \$_;
+    $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset
     my $ldel    = $_1;
     my $rdel    = $_2;
-    my $pre     = defined $_3 ? $_3 : '\s*';
+    my $pre     = defined $_3 ? qr/\G$_3/ : qr/\G\s*/;
     my %options = defined $_4 ? %{$_4} : ();
     my $omode   = defined $options{fail} ? $options{fail} : '';
     my $bad     = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}})
@@ -298,7 +324,7 @@
                 :                                    ''
                 ;
 
-    if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|^>)*>'; }
+    $ldel = $et_default_ldel if !defined $ldel;
     $@ = undef;
 
     my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore);
@@ -316,7 +342,7 @@
 
     my ($startpos, $opentagpos, $textpos, $parapos, $closetagpos, $endpos) = ( pos($$textref) = pos($$textref)||0 );
 
-    unless ($$textref =~ m/\G($pre)/gc)
+    unless ($$textref =~ m/$pre/gc)
     {
         _failmsg "Did not find prefix: /$pre/", pos $$textref;
         goto failed;
@@ -433,7 +459,8 @@
 {
     my $textref = defined $_0 ? \$_0 : \$_;
     return ("","","") unless defined $$textref;
-    my $pre  = defined $_1 ? $_1 : '\s*';
+    $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset
+    my $pre  = defined $_1 ? qr/\G$_1/ : qr/\G\s*/;
 
     my @match = _match_variable($textref,$pre);
 
@@ -443,14 +470,14 @@
                     @match2..3,4..5,0..1;        # MATCH, REMAINDER, PREFIX
 }
 
-sub _match_variable($$)
+sub _match_variable
 {
 #  $#
 #  $^
 #  $$
     my ($textref, $pre) = @_;
     my $startpos = pos($$textref) = pos($$textref)||0;
-    unless ($$textref =~ m/\G($pre)/gc)
+    unless ($$textref =~ m/$pre/gc)
     {
         _failmsg "Did not find prefix: /$pre/", pos $$textref;
         return;
@@ -467,8 +494,9 @@
         my $deref = $1;
 
         unless ($$textref =~ m/\G\s*(?:::|')?(?:_a-z\w*(?:::|'))*_a-z\w*/gci
-            or _match_codeblock($textref, "", '\{', '\}', '\{', '\}', 0)
-            or $deref eq '$#' or $deref eq '$$' )
+            or _match_codeblock($textref, qr/\G()/, '\{', qr/\G\s*(\})/, '\{', '\}', 0, 1)
+            or $deref eq '$#' or $deref eq '$$'
+            or pos($$textref) == length $$textref )
         {
             _failmsg "Bad identifier after dereferencer", pos $$textref;
             pos $$textref = $startpos;
@@ -480,16 +508,17 @@
     {
         next if $$textref =~ m/\G\s*(?:->)?\s*{\w+}/gc;
         next if _match_codeblock($textref,
-                                 qr/\s*->\s*(?:_a-zA-Z\w+\s*)?/,
-                                 qr/({/, qr/)}\/,
-                                 qr/({/, qr/)}\/, 0);
+                                 qr/\G\s*->\s*(?:_a-zA-Z\w+\s*)?/,
+                                 qr/({/, qr/\G\s*()}\)/,
+                                 qr/({/, qr/)}\/, 0, 1);
         next if _match_codeblock($textref,
-                                 qr/\s*/, qr/{/, qr/}\/,
-                                 qr/{/, qr/}\/, 0);
-        next if _match_variable($textref,'\s*->\s*');
+                                 qr/\G\s*/, qr/{/, qr/\G\s*(}\)/,
+                                 qr/{/, qr/}\/, 0, 1);
+        next if _match_variable($textref,qr/\G\s*->\s*/);
         next if $$textref =~ m/\G\s*->\s*\w+(?!{()/gc;
         last;
     }
+    $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 0;
 
     my $endpos = pos($$textref);
     return ($startpos, $varpos-$startpos,
@@ -498,14 +527,11 @@
     );
 }
 
-sub extract_codeblock (;$$$$$)
-{
-    my $textref = defined $_0 ? \$_0 : \$_;
-    my $wantarray = wantarray;
-    my $ldel_inner = defined $_1 ? $_1 : '{';
-    my $pre        = defined $_2 ? $_2 : '\s*';
-    my $ldel_outer = defined $_3 ? $_3 : $ldel_inner;
-    my $rd         = $_4;
+my %ec_delim_cache;
+sub _ec_delims {
+    my ($ldel_inner, $ldel_outer) = @_;
+    return @{ $ec_delim_cache{$ldel_outer}{$ldel_inner} }
+        if $ec_delim_cache{$ldel_outer}{$ldel_inner};
     my $rdel_inner = $ldel_inner;
     my $rdel_outer = $ldel_outer;
     my $posbug = pos;
@@ -516,23 +542,34 @@
         $_ = '('.join('|',map { quotemeta $_ } split('',$_)).')'
     }
     pos = $posbug;
+    @{ $ec_delim_cache{$ldel_outer}{$ldel_inner} = 
+        $ldel_outer, qr/\G\s*($rdel_outer)/, $ldel_inner, $rdel_inner
+     };
+}
+sub extract_codeblock (;$$$$$)
+{
+    my $textref = defined $_0 ? \$_0 : \$_;
+    $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset
+    my $wantarray = wantarray;
+    my $ldel_inner = defined $_1 ? $_1 : '{';
+    my $pre = !defined $_2 ? qr/\G\s*/ : qr/\G$_2/;
+    my $ldel_outer = defined $_3 ? $_3 : $ldel_inner;
+    my $rd         = $_4;
+    my @delims = _ec_delims($ldel_inner, $ldel_outer);
 
-    my @match = _match_codeblock($textref, $pre,
-                                 $ldel_outer, $rdel_outer,
-                                 $ldel_inner, $rdel_inner,
-                                 $rd);
+    my @match = _match_codeblock($textref, $pre, @delims, $rd, 1);
     return _fail($wantarray, $textref) unless @match;
     return _succeed($wantarray, $textref,
                     @match2..3,4..5,0..1    # MATCH, REMAINDER, PREFIX
     );
-
 }
 
-sub _match_codeblock($$$$$$$)
+sub _match_codeblock
 {
-    my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd) = @_;
+    my ($textref, $pre, $ldel_outer, $rdel_outer, $ldel_inner, $rdel_inner, $rd, $no_backcompat) = @_;
+    $rdel_outer = qr/\G\s*($rdel_outer)/ if !$no_backcompat; # Switch calls this func directly
     my $startpos = pos($$textref) = pos($$textref) || 0;
-    unless ($$textref =~ m/\G($pre)/gc)
+    unless ($$textref =~ m/$pre/gc)
     {
         _failmsg qq{Did not match prefix /$pre/ at"} .
                      substr($$textref,pos($$textref),20) .
@@ -553,13 +590,13 @@
     my $closing = $1;
        $closing =~ tr/(<{/)>}/;
     my $matched;
-    my $patvalid = 1;
+    $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0
+      if !pos($$textref) or !defined $ref2slashvalid{$textref}; # default, or reset
     while (pos($$textref) < length($$textref))
     {
-        $matched = '';
         if ($rd && $$textref =~ m#\G(\Q(?)\E|\Q(s?)\E|\Q(s)\E)#gc)
         {
-            $patvalid = 0;
+            $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 0;
             next;
         }
 
@@ -568,7 +605,7 @@
             next;
         }
 
-        if ($$textref =~ m/\G\s*($rdel_outer)/gc)
+        if ($$textref =~ m/$rdel_outer/gc)
         {
             unless ($matched = ($closing && $1 eq $closing) )
             {
@@ -581,31 +618,22 @@
             last;
         }
 
-        if (_match_variable($textref,'\s*') ||
-            _match_quotelike($textref,'\s*',$patvalid,$patvalid) )
+        if (_match_variable($textref,qr/\G\s*/) ||
+            _match_quotelike($textref,qr/\G\s*/,$ref2slashvalid{$textref},$ref2qmarkvalid{$textref}) )
         {
-            $patvalid = 0;
+            $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 0;
             next;
         }
 
-
-        # NEED TO COVER MANY MORE CASES HERE!!!
-        if ($$textref =~ m#\G\s*(?!$ldel_inner)
-                                ( -+*x/%^&|.=?
-                                | !=~
-                                | =(?!>)
-                                | (\*\*|&&|\|\||<<|>>)=?
-                                | split|grep|map|return
-                                | (
-                                )#gcx)
+        if ($$textref =~ m#\G\s*(?!$ldel_inner)(?:$RE_PREREGEX_PAT|$RE_EXPR_PAT)#gc)
         {
-            $patvalid = 1;
+            $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 1;
             next;
         }
 
-        if ( _match_codeblock($textref, '\s*', $ldel_inner, $rdel_inner, $ldel_inner, $rdel_inner, $rd) )
+        if ( _match_codeblock($textref, qr/\G\s*/, $ldel_inner, qr/\G\s*($rdel_inner)/, $ldel_inner, $rdel_inner, $rd, 1) )
         {
-            $patvalid = 1;
+            $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 1;
             next;
         }
 
@@ -618,7 +646,7 @@
             last;
         }
 
-        $patvalid = 0;
+        $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 0;
         $$textref =~ m/\G\s*(\w+|-=>>|.|\Z)/gc;
     }
     continue { $@ = undef }
@@ -630,6 +658,7 @@
         return;
     }
 
+    $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = undef;
     my $endpos = pos($$textref);
     return ( $startpos, $codepos-$startpos,
              $codepos, $endpos-$codepos,
@@ -654,10 +683,11 @@
 sub extract_quotelike (;$$)
 {
     my $textref = $_0 ? \$_0 : \$_;
+    $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset
     my $wantarray = wantarray;
-    my $pre  = defined $_1 ? $_1 : '\s*';
+    my $pre  = defined $_1 ? qr/\G$_1/ : qr/\G\s*/;
 
-    my @match = _match_quotelike($textref,$pre,1,0);
+    my @match = _match_quotelike($textref,$pre,$ref2slashvalid{$textref},$ref2qmarkvalid{$textref});
     return _fail($wantarray, $textref) unless @match;
     return _succeed($wantarray, $textref,
                     $match2, $match18-$match2,    # MATCH
@@ -668,17 +698,19 @@
     );
 };
 
-sub _match_quotelike($$$$)      # ($textref, $prepat, $allow_raw_match)
+my %maybe_quote = map +($_=>1), qw(" ' `);
+sub _match_quotelike
 {
-    my ($textref, $pre, $rawmatch, $qmark) = @_;
+    my ($textref, $pre, $allow_slash_match, $allow_qmark_match) = @_;
+    $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0
+      if !pos($$textref) or !defined $ref2slashvalid{$textref}; # default, or reset
 
     my ($textlen,$startpos,
-        $oppos,
         $preld1pos,$ld1pos,$str1pos,$rd1pos,
         $preld2pos,$ld2pos,$str2pos,$rd2pos,
         $modpos) = ( length($$textref), pos($$textref) = pos($$textref) || 0 );
 
-    unless ($$textref =~ m/\G($pre)/gc)
+    unless ($$textref =~ m/$pre/gc)
     {
         _failmsg qq{Did not find prefix /$pre/ at "} .
                      substr($$textref, pos($$textref), 20) .
@@ -686,15 +718,13 @@
                  pos $$textref;
         return;
     }
-    $oppos = pos($$textref);
-
+    my $oppos = pos($$textref);
     my $initial = substr($$textref,$oppos,1);
-
-    if ($initial && $initial =~ m|^\"\'\`|
-                 || $rawmatch && $initial =~ m|^/|
-                 || $qmark && $initial =~ m|^\?|)
+    if ($initial && $maybe_quote{$initial}
+                 || $allow_slash_match && $initial eq '/'
+                 || $allow_qmark_match && $initial eq '?')
     {
-        unless ($$textref =~ m/ \Q$initial\E ^\\$initial* (\\.^\\$initial*)* \Q$initial\E /gcsx)
+        unless ($$textref =~ m/\G \Q$initial\E ^\\$initial* (\\.^\\$initial*)* \Q$initial\E /gcsx)
         {
             _failmsg qq{Did not find closing delimiter to match '$initial' at "} .
                          substr($$textref, $oppos, 20) .
@@ -712,6 +742,7 @@
         }
 
         my $endpos = pos($$textref);
+        $ref2qmarkvalid{$textref} = $ref2slashvalid{$textref} = 0;
         return (
             $startpos,  $oppos-$startpos,       # PREFIX
             $oppos,     0,                      # NO OPERATOR
@@ -726,7 +757,7 @@
         );
     }
 
-    unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<)}gc)
+    unless ($$textref =~ m{\G(\b(?:m|s|qq|qx|qw|q|qr|tr|y)\b(?=\s*\S)|<<(?=a-zA-Z|\s*'"`;,))}gc)
     {
         _failmsg q{No quotelike operator found after prefix at "} .
                      substr($$textref, pos($$textref), 20) .
@@ -767,6 +798,7 @@
         $rd1pos = pos($$textref);
         $$textref =~ m{\Q$label\E\n}gc;
         $ld2pos = pos($$textref);
+        $ref2qmarkvalid{$textref} = $ref2slashvalid{$textref} = 0;
         return (
             $startpos,  $oppos-$startpos,       # PREFIX
             $oppos,     length($op),            # OPERATOR
@@ -786,19 +818,26 @@
     $ld1pos = pos($$textref);
     $str1pos = $ld1pos+1;
 
-    unless ($$textref =~ m/\G(\S)/gc)   # SHOULD USE LOOKAHEAD
+    if ($$textref !~ m/\G(\S)/gc)   # SHOULD USE LOOKAHEAD
     {
         _failmsg "No block delimiter found after quotelike $op",
                  pos $$textref;
         pos $$textref = $startpos;
         return;
     }
+    elsif (substr($$textref, $ld1pos, 2) eq '=>')
+    {
+        _failmsg "quotelike $op was actually quoted by '=>'",
+                 pos $$textref;
+        pos $$textref = $startpos;
+        return;
+    }
     pos($$textref) = $ld1pos;   # HAVE TO DO THIS BECAUSE LOOKAHEAD BROKEN
     my ($ldel1, $rdel1) = ("\Q$1","\Q$1");
     if ($ldel1 =~ /(<{/)
     {
         $rdel1 =~ tr/({</)}>/;
-        defined(_match_bracketed($textref,"",$ldel1,"","",$rdel1))
+        defined(_match_bracketed($textref,qr/\G/,qr/\G($ldel1)/,"","",qr/\G($rdel1)/))
             || do { pos $$textref = $startpos; return };
         $ld2pos = pos($$textref);
         $rd1pos = $ld2pos-1;
@@ -835,7 +874,7 @@
         if ($ldel2 =~ /(<{/)
         {
             pos($$textref)--;   # OVERCOME BROKEN LOOKAHEAD
-            defined(_match_bracketed($textref,"",$ldel2,"","",$rdel2))
+            defined(_match_bracketed($textref,qr/\G/,qr/\G($ldel2)/,"","",qr/\G($rdel2)/))
                 || do { pos $$textref = $startpos; return };
         }
         else
@@ -854,6 +893,7 @@
 
     $$textref =~ m/\G($mods{$op})/gc;
     my $endpos = pos $$textref;
+    $ref2qmarkvalid{$textref} = $ref2slashvalid{$textref} = undef;
 
     return (
         $startpos,      $oppos-$startpos,       # PREFIX
@@ -874,10 +914,26 @@
     sub { extract_quotelike($_0,'') },
     sub { extract_codeblock($_0,'{}','') },
 ;
+my %ref_not_regex = map +($_=>1), qw(CODE Text::Balanced::Extractor);
 
+sub _update_patvalid {
+    my ($textref, $text) = @_;
+    if ($ref2slashvalid{$textref} && $text =~ m/(?:$RE_NUM|\)\)\s*$/)
+    {
+        $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 0;
+    } elsif (!$ref2slashvalid{$textref} && $text =~ m/$RE_PREREGEX_PAT\s*$/)
+    {
+        $ref2slashvalid{$textref} = $ref2qmarkvalid{$textref} = 1;
+    } elsif (!$ref2slashvalid{$textref} && $text =~ m/$RE_EXPR_PAT\s*$/)
+    {
+        $ref2slashvalid{$textref} = 1;
+        $ref2qmarkvalid{$textref} = 0;
+    }
+}
 sub extract_multiple (;$$$$)    # ($text, $functions_ref, $max_fields, $ignoreunknown)
 {
     my $textref = defined($_0) ? \$_0 : \$_;
+    $ref2slashvalid{$textref} = 1, $ref2qmarkvalid{$textref} = 0 if !pos($$textref); # reset
     my $posbug = pos;
     my ($lastpos, $firstpos);
     my @fields = ();
@@ -898,39 +954,28 @@
             $max = 1
         }
 
-        my $unkpos;
-        my $class;
-
         my @class;
         foreach my $func ( @func )
         {
-            if (ref($func) eq 'HASH')
-            {
-                push @class, (keys %$func)0;
-                $func = (values %$func)0;
-            }
-            else
-            {
-                push @class, undef;
-            }
+            push @class, undef;
+            ($class-1, $func) = %$func if ref($func) eq 'HASH';
+            $func = qr/\G$func/ if !$ref_not_regex{ref $func};
         }
 
+        my $unkpos;
         FIELD: while (pos($$textref) < length($$textref))
         {
-            my ($field, $rem);
-            my @bits;
             foreach my $i ( 0..$#func )
             {
-                my $pref;
-                my $func = $func$i;
-                $class = $class$i;
+                my ($field, $pref);
+                my ($class, $func) = ($class$i, $func$i);
                 $lastpos = pos $$textref;
                 if (ref($func) eq 'CODE')
-                    { ($field,$rem,$pref) = @bits = $func->($$textref) }
+                    { ($field,undef,$pref) = $func->($$textref) }
                 elsif (ref($func) eq 'Text::Balanced::Extractor')
-                    { @bits = $field = $func->extract($$textref) }
-                elsif( $$textref =~ m/\G$func/gc )
-                    { @bits = $field = defined($1)
+                    { $field = $func->extract($$textref) }
+                elsif( $$textref =~ m/$func$i/gc )
+                    { $field = defined($1)
                         ? $1
                         : substr($$textref, $-0, $+0 - $-0)
                     }
@@ -948,9 +993,8 @@
                             last FIELD if @fields == $max;
                         }
                     }
-                    push @fields, $class
-                            ? bless (\$field, $class)
-                            : $field;
+                    push @fields, $class ? bless(\$field, $class) : $field;
+                    _update_patvalid($textref, $fields-1);
                     $firstpos = $lastpos unless defined $firstpos;
                     $lastpos = pos $$textref;
                     last FIELD if @fields == $max;
@@ -961,6 +1005,7 @@
             {
                 $unkpos = pos($$textref)-1
                     unless $igunk || defined $unkpos;
+                _update_patvalid($textref, substr $$textref, $unkpos, pos($$textref)-$unkpos);
             }
         }
 
@@ -986,7 +1031,7 @@
 {
     my $ldel    = $_0;
     my $rdel    = $_1;
-    my $pre     = defined $_2 ? $_2 : '\s*';
+    my $pre     = defined $_2 ? qr/\G$_2/ : qr/\G\s*/;
     my %options = defined $_3 ? %{$_3} : ();
     my $omode   = defined $options{fail} ? $options{fail} : '';
     my $bad     = ref($options{reject}) eq 'ARRAY' ? join('|', @{$options{reject}})
@@ -998,16 +1043,16 @@
                 :                                    ''
                 ;
 
-    if (!defined $ldel) { $ldel = '<\w+(?:' . gen_delimited_pat(q{'"}) . '|^>)*>'; }
+    $ldel = $et_default_ldel if !defined $ldel;
 
     my $posbug = pos;
-    for ($ldel, $pre, $bad, $ignore) { $_ = qr/$_/ if $_ }
+    for ($ldel, $bad, $ignore) { $_ = qr/$_/ if $_ }
     pos = $posbug;
 
     my $closure = sub
     {
         my $textref = defined $_0 ? \$_0 : \$_;
-        my @match = Text::Balanced::_match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore);
+        my @match = _match_tagged($textref, $pre, $ldel, $rdel, $omode, $bad, $ignore);
 
         return _fail(wantarray, $textref) unless @match;
         return _succeed wantarray, $textref,
@@ -1027,7 +1072,9 @@
 
 package Text::Balanced::ErrorMsg;
 
-use overload '""' => sub { "$_0->{error}, detected at offset $_0->{pos}" };
+use overload
+    '""' => sub { "$_0->{error}, detected at offset $_0->{pos}" },
+    fallback => 1;
 
 1;
 
@@ -1450,7 +1497,7 @@
 
 =item 2.
 
-A string specifying a pattern to be matched as the opening tag.
+A string specifying a pattern (i.e. regex) to be matched as the opening tag.
 If the pattern string is omitted (or C<undef>) then a pattern
 that matches any standard XML tag is used.
 
@@ -1854,7 +1901,8 @@
 C<extract_codeblock> takes the same initial three parameters as C<extract_bracketed>:
 a text to process, a set of delimiter brackets to look for, and a prefix to
 match first. It also takes an optional fourth parameter, which allows the
-outermost delimiter brackets to be specified separately (see below).
+outermost delimiter brackets to be specified separately (see below),
+and a fifth parameter used only by L<Parse::RecDescent>.
 
 Omitting the first argument (input text) means process C<$_> instead.
 Omitting the second argument (delimiter brackets) indicates that only C<'{'> is to be used.
@@ -2063,12 +2111,14 @@
 
 Finally, here is yet another way to do comma-separated value parsing:
 
+        $csv_text = "a,'x b',c";
         @fields = extract_multiple($csv_text,
                                   
                                         sub { extract_delimited($_0,q{'"}) },
-                                        qr/(^,+)(.*)/,
+                                        qr/(^,+)/,
                                   ,
                                   undef,1);
+        # @fields is now ('a', "'x b'", 'c')
 
 The list in the second argument means:
 I<"Try and extract a ' or " delimited string, otherwise extract anything up to a comma...">.
@@ -2084,7 +2134,7 @@
 =item C<gen_delimited_pat>
 
 The C<gen_delimited_pat> subroutine takes a single (string) argument and
-   > builds a Friedl-style optimized regex that matches a string delimited
+builds a Friedl-style optimized regex that matches a string delimited
 by any one of the characters in the single argument. For example:
 
         gen_delimited_pat(q{'"})
@@ -2360,7 +2410,8 @@
 
 Copyright (C) 2009 Adam Kennedy.
 
-Copyright (C) 2015, 2020 Steve Hay.  All rights reserved.
+Copyright (C) 2015, 2020, 2022 Steve Hay and other contributors.  All rights
+reserved.
 
 =head1 LICENCE
 
@@ -2370,11 +2421,11 @@
 
 =head1 VERSION
 
-Version 2.04
+Version 2.06
 
 =head1 DATE
 
-11 Dec 2020
+05 Jun 2022
 
 =head1 HISTORY

_service:tar_scm:Text-Balanced-2.04.tar.gz/t/01_compile.t -> _service:tar_scm:Text-Balanced-2.06.tar.gz/t/01_compile.t Changed

_service:tar_scm:Text-Balanced-2.04.tar.gz/t/02_extbrk.t -> _service:tar_scm:Text-Balanced-2.06.tar.gz/t/02_extbrk.t Changed

@@ -1,27 +1,12 @@
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
-
 use 5.008001;
 
 use strict;
 use warnings;
-
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-
-my $loaded = 0;
-BEGIN { $| = 1; print "1..19\n"; }
-END {print "not ok 1\n" unless $loaded;}
+use Test::More;
 use Text::Balanced qw ( extract_bracketed );
-$loaded = 1;
-print "ok 1\n";
-my $count=2;
-use vars qw( $DEBUG );
-sub debug { print "\t>>>",@_ if $DEBUG }
 
-######################### End of black magic.
+our $DEBUG;
+sub debug { print "\t>>>",@_ if $DEBUG }
 
 ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
@@ -34,6 +19,7 @@
     if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
     elsif ($str =~ /\A# THEISE? SHOULD FAIL/) { $neg = 1; next; }
     elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+    my $orig_str = $str;
     $str =~ s/\\n/\n/g;
     debug "\tUsing: $cmd\n";
     debug "\t   on: $str\n";
@@ -41,22 +27,20 @@
     my $var = eval "() = $cmd";
     debug "\t list got: $var\n";
     debug "\t list left: $str\n";
-    print "not " if (substr($str,pos($str),1) eq ';')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list");
+    diag $@ if $@ && $DEBUG;
 
     pos $str = 0;
     $var = eval $cmd;
     $var = "<undef>" unless defined $var;
     debug "\t scalar got: $var\n";
     debug "\t scalar left: $str\n";
-    print "not " if ($str =~ '\A;')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar");
+    diag $@ if $@ && $DEBUG;
 }
 
+done_testing;
+
 __DATA__
 
 # USING: extract_bracketed($str);

_service:tar_scm:Text-Balanced-2.04.tar.gz/t/03_extcbk.t -> _service:tar_scm:Text-Balanced-2.06.tar.gz/t/03_extcbk.t Changed

@@ -1,27 +1,12 @@
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
-
 use 5.008001;
 
 use strict;
 use warnings;
-
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-
-my $loaded = 0;
-BEGIN { $| = 1; print "1..41\n"; }
-END {print "not ok 1\n" unless $loaded;}
+use Test::More;
 use Text::Balanced qw ( extract_codeblock );
-$loaded = 1;
-print "ok 1\n";
-my $count=2;
-use vars qw( $DEBUG );
-sub debug { print "\t>>>",@_ if $DEBUG }
 
-######################### End of black magic.
+our $DEBUG;
+sub debug { print "\t>>>",@_ if $DEBUG }
 
 ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
@@ -34,30 +19,47 @@
     if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
     elsif ($str =~ /\A# THEISE? SHOULD FAIL/) { $neg = 1; next; }
     elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+    my $orig_str = $str;
     $str =~ s/\\n/\n/g;
     debug "\tUsing: $cmd\n";
     debug "\t   on: $str\n";
 
     my @res;
     my $var = eval "\@res = $cmd";
-    debug "\t   Failed: $@ at " . $@+0 .")" if $@;
+    is $@, '', 'no error';
     debug "\t list got: " . join("|", map {defined $_ ? $_ : '<undef>'} @res) . "\n";
     debug "\t list left: $str\n";
-    print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
-    print "ok ", $count++;
-    print "\n";
+    ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list");
 
     pos $str = 0;
     $var = eval $cmd;
+    is $@, '', 'no error';
     $var = "<undef>" unless defined $var;
     debug "\t scalar got: $var\n";
     debug "\t scalar left: $str\n";
-    print "not " if ($str =~ '\A;')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar");
 }
 
+my $grammar = <<'EOF';
+given 2 { when __ < 1 { ok(0) } else { ok(1) } }
+EOF
+pos $grammar = 8;
+my ($out) = Text::Balanced::_match_codeblock(\$grammar,qr/\s*/,qr/\{/,qr/\}/,qr/\{/,qr/\}/,undef);
+ok $out, 'Switch error from calling _match_codeblock';
+
+$grammar = <<'EOF';
+comment:  m/a/
+enum_list: (/b/)
+EOF
+pos $grammar = 10;
+($out) = Text::Balanced::extract_quotelike($grammar);
+is $out, 'm/a/', 'PRD error (setup for real error)';
+pos $grammar = 26;
+($out) = extract_codeblock($grammar,'{(',undef,'(',1);
+is $out, '(/b/)', 'PRD error';
+
+done_testing;
+
 __DATA__
 
 # USING: extract_codeblock($str,'(){}',undef,'()');
@@ -65,6 +67,13 @@
 
 # USING: extract_codeblock($str);
 { $data4 =~ /'"/; };
+{1<<2};
+{1<<2};\n
+{1<<2};\n\n
+{ $a = /\}/; };
+{ sub { $_0 /= $_1 } };  # / here
+{ 1; };
+{ $a = 1; };
 
 # USING: extract_codeblock($str,'<>');
 < %x = ( try => "this") >;
@@ -77,13 +86,9 @@
 # THIS SHOULD FAIL
 < %x = do { $try > 10 } >;
 
-# USING: extract_codeblock($str);
-
-{ $a = /\}/; };
-{ sub { $_0 /= $_1 } };  # / here
-{ 1; };
-{ $a = 1; };
-
+# USING: extract_codeblock($str, '()');
+(($x || 2)); split /z/, $y
+(($x // 2)); split /z/, $y
 
 # USING: extract_codeblock($str,undef,'=*');
 ========{$a=1};

_service:tar_scm:Text-Balanced-2.04.tar.gz/t/04_extdel.t -> _service:tar_scm:Text-Balanced-2.06.tar.gz/t/04_extdel.t Changed

@@ -1,28 +1,13 @@
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
-
 use 5.008001;
 
 use strict;
 use warnings;
+use Test::More;
+use Text::Balanced qw ( extract_delimited extract_multiple );
 
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-
-my $loaded = 0;
-BEGIN { $| = 1; print "1..45\n"; }
-END {print "not ok 1\n" unless $loaded;}
-use Text::Balanced qw ( extract_delimited );
-$loaded = 1;
-print "ok 1\n";
-my $count=2;
-use vars qw( $DEBUG );
+our $DEBUG;
 sub debug { print "\t>>>",@_ if $DEBUG }
 
-######################### End of black magic.
-
 ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
 my $cmd = "print";
@@ -34,29 +19,41 @@
     if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
     elsif ($str =~ /\A# THEISE? SHOULD FAIL/) { $neg = 1; next; }
     elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+    my $orig_str = $str;
     $str =~ s/\\n/\n/g;
     debug "\tUsing: $cmd\n";
     debug "\t   on: $str\n";
 
     my $var = eval "() = $cmd";
+    is $@, '', 'no error';
     debug "\t list got: $var\n";
     debug "\t list left: $str\n";
-    print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list");
 
     pos $str = 0;
     $var = eval $cmd;
+    is $@, '', 'no error';
     $var = "<undef>" unless defined $var;
     debug "\t scalar got: $var\n";
     debug "\t scalar left: $str\n";
-    print "not " if ($str =~ '\A;')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar");
 }
 
+my $text = 'while($a == "test"){ print "true";}';
+my ($extracted, $remainder) = extract_delimited($text, '#');
+ok '' ne $@, 'string overload should not crash';
+
+$text = "a,'x b',c";
+my @fields = extract_multiple($text,
+ 
+   sub { extract_delimited($_0,q{'"}) },
+   qr/(^,+)/,
+ ,
+ undef,1);
+is_deeply \@fields, 'a', "'x b'", 'c' or diag 'got: ', explain \@fields;
+
+done_testing;
+
 __DATA__
 # USING: extract_delimited($str,'/#$',undef,'/#$');
 /a/;

_service:tar_scm:Text-Balanced-2.04.tar.gz/t/05_extmul.t -> _service:tar_scm:Text-Balanced-2.06.tar.gz/t/05_extmul.t Changed

@@ -1,54 +1,20 @@
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
-
 use 5.008001;
 
 use strict;
 use warnings;
-
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-
-my $loaded = 0;
-BEGIN { $| = 1; print "1..86\n"; }
-END {print "not ok 1\n" unless $loaded;}
+use Test::More;
 use Text::Balanced qw ( :ALL );
-$loaded = 1;
-print "ok 1\n";
-my $count=2;
-use vars qw( $DEBUG );
-sub debug { print "\t>>>",@_ if $DEBUG }
 
-######################### End of black magic.
+our $DEBUG;
+sub debug { print "\t>>>",@_ if $DEBUG }
 
 sub expect
 {
-    local $^W;
     my ($l1, $l2) = @_;
-
-    if (@$l1 != @$l2)
-    {
-        print "\@l1: ", join(", ", @$l1), "\n";
-        print "\@l2: ", join(", ", @$l2), "\n";
-        print "not ";
-    }
-    else
-    {
-        for (my $i = 0; $i < @$l1; $i++)
-        {
-            if ($l1->$i ne $l2->$i)
-            {
-                print "field $i: '$l1->$i' ne '$l2->$i'\n";
-                print "not ";
-                last;
-            }
-        }
-    }
-
-    print "ok $count\n";
-    $count++;
+    is_deeply $l1, $l2 or do {
+        diag 'got:', explain $l1;
+        diag 'expected:', explain $l2;
+    };
 }
 
 sub divide
@@ -66,10 +32,8 @@
 
 }
 
-
 my $stdtext1 = q{$var = do {"val" && $val;};};
 
-# TESTS 2-4
 my $text = $stdtext1;
 expect  extract_multiple($text,undef,1) ,
         divide $stdtext1 => 4 ;
@@ -77,7 +41,6 @@
 expect  pos $text,  4 ;
 expect  $text ,  $stdtext1 ;
 
-# TESTS 5-7
 $text = $stdtext1;
 expect  scalar extract_multiple($text,undef,1) ,
         divide $stdtext1 => 4 ;
@@ -86,7 +49,6 @@
 expect  $text ,  substr($stdtext1,4) ;
 
 
-# TESTS 8-10
 $text = $stdtext1;
 expect  extract_multiple($text,undef,2) ,
         divide($stdtext1 => 4, 10) ;
@@ -94,7 +56,6 @@
 expect  pos $text,  10 ;
 expect  $text ,  $stdtext1 ;
 
-# TESTS 11-13
 $text = $stdtext1;
 expect  eval{local$^W;scalar extract_multiple($text,undef,2)} ,
         substr($stdtext1,0,4) ;
@@ -103,7 +64,6 @@
 expect  $text ,  substr($stdtext1,4) ;
 
 
-# TESTS 14-16
 $text = $stdtext1;
 expect  extract_multiple($text,undef,3) ,
         divide($stdtext1 => 4, 10, 26) ;
@@ -111,7 +71,6 @@
 expect  pos $text,  26 ;
 expect  $text ,  $stdtext1 ;
 
-# TESTS 17-19
 $text = $stdtext1;
 expect  eval{local$^W;scalar extract_multiple($text,undef,3)} ,
         substr($stdtext1,0,4) ;
@@ -120,7 +79,6 @@
 expect  $text ,  substr($stdtext1,4) ;
 
 
-# TESTS 20-22
 $text = $stdtext1;
 expect  extract_multiple($text,undef,4) ,
         divide($stdtext1 => 4, 10, 26, 27) ;
@@ -128,7 +86,6 @@
 expect  pos $text,  27 ;
 expect  $text ,  $stdtext1 ;
 
-# TESTS 23-25
 $text = $stdtext1;
 expect  eval{local$^W;scalar extract_multiple($text,undef,4)} ,
         substr($stdtext1,0,4) ;
@@ -137,7 +94,6 @@
 expect  $text ,  substr($stdtext1,4) ;
 
 
-# TESTS 26-28
 $text = $stdtext1;
 expect  extract_multiple($text,undef,5) ,
         divide($stdtext1 => 4, 10, 26, 27) ;
@@ -146,7 +102,6 @@
 expect  $text ,  $stdtext1 ;
 
 
-# TESTS 29-31
 $text = $stdtext1;
 expect  eval{local$^W;scalar extract_multiple($text,undef,5)} ,
         substr($stdtext1,0,4) ;
@@ -156,7 +111,6 @@
 
 
 
-# TESTS 32-34
 my $stdtext2 = q{$var = "val" && (1,2,3);};
 
 $text = $stdtext2;
@@ -166,7 +120,6 @@
 expect  pos $text,  24 ;
 expect  $text ,  $stdtext2 ;
 
-# TESTS 35-37
 $text = $stdtext2;
 expect  scalar extract_multiple($text) ,
         substr($stdtext2,0,4) ;
@@ -175,7 +128,6 @@
 expect  $text ,  substr($stdtext2,4) ;
 
 
-# TESTS 38-40
 $text = $stdtext2;
 expect  extract_multiple($text,\&extract_bracketed) ,
         substr($stdtext2,0,16), substr($stdtext2,16,7), substr($stdtext2,23) ;
@@ -183,7 +135,6 @@
 expect  pos $text,  24 ;
 expect  $text ,  $stdtext2 ;
 
-# TESTS 41-43
 $text = $stdtext2;
 expect  scalar extract_multiple($text,\&extract_bracketed) ,
         substr($stdtext2,0,16) ;
@@ -192,7 +143,6 @@
 expect  $text ,  substr($stdtext2,15) ;
 
 
-# TESTS 44-46
 $text = $stdtext2;
 expect  extract_multiple($text,\&extract_variable) ,
         substr($stdtext2,0,4), substr($stdtext2,4) ;
@@ -200,7 +150,6 @@
 expect  pos $text,  length($text) ;
 expect  $text ,  $stdtext2 ;
 
-# TESTS 47-49
 $text = $stdtext2;
 expect  scalar extract_multiple($text,\&extract_variable) ,
         substr($stdtext2,0,4) ;
@@ -209,7 +158,6 @@
 expect  $text ,  substr($stdtext2,4) ;
 
 
-# TESTS 50-52
 $text = $stdtext2;
 expect  extract_multiple($text,\&extract_quotelike) ,
         substr($stdtext2,0,7), substr($stdtext2,7,5), substr($stdtext2,12) ;
@@ -217,7 +165,6 @@
 expect  pos $text,  length($text) ;
 expect  $text ,  $stdtext2 ;
 
-# TESTS 53-55
 $text = $stdtext2;
 expect  scalar extract_multiple($text,\&extract_quotelike) ,
         substr($stdtext2,0,7) ;
@@ -226,7 +173,6 @@
 expect  $text ,  substr($stdtext2,6) ;
 
 
-# TESTS 56-58
 $text = $stdtext2;
 expect  extract_multiple($text,\&extract_quotelike,2,1) ,
         substr($stdtext2,7,5) ;
@@ -234,7 +180,6 @@
 expect  pos $text,  23 ;
 expect  $text ,  $stdtext2 ;
 
-# TESTS 59-61
 $text = $stdtext2;
 expect  eval{local$^W;scalar extract_multiple($text,\&extract_quotelike,2,1)} ,
         substr($stdtext2,7,5) ;
@@ -243,7 +188,6 @@
 expect  $text ,  substr($stdtext2,0,6). substr($stdtext2,12) ;
 
 
-# TESTS 62-64
 $text = $stdtext2;
 expect  extract_multiple($text,\&extract_quotelike,1,1) ,
         substr($stdtext2,7,5) ;
@@ -251,7 +195,6 @@
 expect  pos $text,  12 ;
 expect  $text ,  $stdtext2 ;
 
-# TESTS 65-67
 $text = $stdtext2;
 expect  scalar extract_multiple($text,\&extract_quotelike,1,1) ,
         substr($stdtext2,7,5) ;
@@ -259,7 +202,6 @@
 expect  pos $text,  6 ;
 expect  $text ,  substr($stdtext2,0,6). substr($stdtext2,12) ;
 
-# TESTS 68-70
 my $stdtext3 = "a,b,c";
 
 $_ = $stdtext3;
@@ -269,8 +211,6 @@
 expect  pos ,  5 ;
 expect  $_ ,  $stdtext3 ;
 
-# TESTS 71-73
-
 $_ = $stdtext3;
 expect  scalar extract_multiple(undef,  sub { /\Ga-z/gc && $& } ) ,
         divide($stdtext3 => 1) ;
@@ -278,9 +218,6 @@
 expect  pos ,  0 ;
 expect  $_ ,  substr($stdtext3,1) ;
 
-
-# TESTS 74-76
-
 $_ = $stdtext3;
 expect  extract_multiple(undef,  qr/\Ga-z/ ) ,
         divide($stdtext3 => 1,2,3,4,5) ;
@@ -288,8 +225,6 @@
 expect  pos ,  5 ;
 expect  $_ ,  $stdtext3 ;
 
-# TESTS 77-79
-
 $_ = $stdtext3;
 expect  scalar extract_multiple(undef,  qr/\Ga-z/ ) ,
         divide($stdtext3 => 1) ;
@@ -297,9 +232,6 @@
 expect  pos ,  0 ;
 expect  $_ ,  substr($stdtext3,1) ;
 
-
-# TESTS 80-82
-
 $_ = $stdtext3;
 expect  extract_multiple(undef,  q/(a-z),?/ ) ,
         qw(a b c) ;
@@ -307,8 +239,6 @@
 expect  pos ,  5 ;
 expect  $_ ,  $stdtext3 ;
 
-# TESTS 83-85
-
 $_ = $stdtext3;
 expect  scalar extract_multiple(undef,  q/(a-z),?/ ) ,
         divide($stdtext3 => 1) ;
@@ -316,10 +246,134 @@
 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' ;
+
+my $not_here_doc = "sub f {\n my \$pa <<= 2;\n}\n\n"; # wrong in 2.04
+expect  extract_multiple($not_here_doc, 
+  { DONT_MATCH => \&extract_quotelike }
+) ,
+        "sub f {\n my \$pa <<= 2;\n}\n\n" ;
+
+my $y_falsematch = <<'EOF'; # wrong in 2.04
+my $p = {y => 1};
+{ $pa=ones(3,3,3); my $f = do { my $i=1; my $v=$$p{y}-$i; $pb = $pa(,$i,) }; }
+EOF
+expect  extract_multiple($y_falsematch, 
+  \&extract_variable,
+  { DONT_MATCH => \&extract_quotelike }
+) ,
+   'my ', '$p', " = {y => 1};\n{ ", '$pa', '=ones(3,3,3); my ', '$f',
+    ' = do { my ', '$i', '=1; my ', '$v', qw(= $$p{y} - $i), '; ', '$pb',
+    ' = ', '$pa', '(,', '$i', ",) }; }\n",
+  ;
+
+my $slashmatch = <<'EOF'; # wrong in 2.04
+my $var = 10 / 3; if ($var !~ /\./) { decimal() ;}
+EOF
+my @expect_slash = ('my ', '$var', ' = 10 / 3; if (', '$var', " !~ ",
+  '/\\./', ") { decimal() ;}\n"
+);
+expect  extract_multiple($slashmatch, 
+  \&extract_variable,
+  \&extract_quotelike,
+) ,
+  \@expect_slash;
+
+$slashmatch = <<'EOF'; # wrong in 2.04
+my $var = 10 / 3; if ($var =~ /\./) { decimal() ;}
+EOF
+$expect_slash4 = " =~ ";
+expect  extract_multiple($slashmatch, 
+  \&extract_variable,
+  \&extract_quotelike,
+) ,
+  \@expect_slash;
+
+$slashmatch = <<'EOF'; # wrong in 2.04
+my $var = 10 / 3; if ($var =~
+  # a comment
+  /\./) { decimal() ;}
+EOF
+my $comment = qr/(?<!\$\@%)#.*/;
+my $id = qr/\b(?!(ysm|qrqxw?|tr)\b)\w+/;
+expect  extract_multiple($slashmatch, 
+  $comment,
+  \&extract_variable,
+  $id,
+  \&extract_quotelike,
+) ,
+   'my', ' ', '$var', ' = ', '10', ' / ', '3', '; ', 'if', ' (', '$var',
+    " =~\n  ", '# a comment', "\n  ", '/\\./', ') { ', 'decimal', "() ;}\n"
+  ;
+
+$slashmatch = <<'EOF'; # wrong in 2.04_01
+my $r=(1-$PCi)/1+czip(1, -1)/czip(1, 1);
+EOF
+expect  extract_multiple($slashmatch, 
+  \&extract_variable, $id, \&extract_quotelike,
+) ,
+  
+  'my', ' ', '$r', '=(', '1', '-', '$PCi', ')/', '1', '+',
+  'czip', '(', '1', ', -', '1', ')/',
+  'czip', '(', '1', ', ', '1', ");\n"
+  ;
+
+$slashmatch = <<'EOF'; # wrong in 2.04_01
+$ndim--; $min = $mdim <= $ndim ? 1 : 0; $min = $mdim < $ndim ? 1 : 0;
+EOF
+expect  extract_multiple($slashmatch, 
+  \&extract_variable, $id, \&extract_quotelike,
+) ,
+  
+  '$ndim', '--; ',
+  '$min', ' = ', '$mdim', ' <= ', '$ndim', ' ? ', '1', ' : ', '0', '; ',
+  '$min', ' = ', '$mdim', ' < ', '$ndim', ' ? ', '1', ' : ', '0', ";\n"
+  ;
+
+$slashmatch = <<'EOF'; # wrong in 2.04_01
+$x->t->(($a))->sever;
+wantarray ? 1 : 0; $min = $var ? 0;
+EOF
+expect  extract_multiple($slashmatch, 
+  \&extract_variable, $id, \&extract_quotelike,
+) ,
+  
+  '$x->t->(($a))->sever', ";\n",
+  'wantarray', ' ? ', '1', ' : ', '0', '; ',
+  '$min', ' = ', '$var', ' ? ', '0', ";\n",
+  ;
+
+$slashmatch = <<'EOF'; # wrong in 2.04_01
+$var //= 'default'; $x = 1 / 2;
+EOF
+expect  extract_multiple($slashmatch, 
+  \&extract_variable, \&extract_quotelike,
+) ,
+  
+  '$var', ' //= ', '\'default\'', '; ', '$x', " = 1 / 2;\n"
+  ;
+
+$slashmatch = <<'EOF'; # wrong in 2.04_01
+$m; return wantarray ? ($m, $i) : $var ? $m : 0;
+EOF
+expect  extract_multiple($slashmatch, 
+  \&extract_variable, \&extract_quotelike,
+) ,
+  
+  '$m',
+  '; return wantarray ? (', '$m', ', ', '$i', ') : ', '$var', ' ? ', '$m',
+  " : 0;\n"
+  ;
+
+$slashmatch = <<'EOF'; # wrong in 2.05
+$_ = 1 unless defined $_ and /\d\b/;
+EOF
+expect  extract_multiple($slashmatch, 
+  \&extract_variable, \&extract_quotelike,
+) ,
+   '$_', ' = 1 unless defined ', '$_', ' and ', '/\\d\\b/', ";\n" ;
+
+done_testing;

_service:tar_scm:Text-Balanced-2.04.tar.gz/t/06_extqlk.t -> _service:tar_scm:Text-Balanced-2.06.tar.gz/t/06_extqlk.t Changed

@@ -1,30 +1,13 @@
-#! /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'
-
 use 5.008001;
 
 use strict;
 use warnings;
-
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-
-my $loaded = 0;
-BEGIN { $| = 1; print "1..95\n"; }
-END {print "not ok 1\n" unless $loaded;}
+use Test::More;
 use Text::Balanced qw ( extract_quotelike );
-$loaded = 1;
-print "ok 1\n";
-my $count=2;
-use vars qw( $DEBUG );
-#$DEBUG=1;
-sub debug { print "\t>>>",@_ if $ENV{DEBUG} }
-sub esc   { my $x = shift||'<undef>'; $x =~ s/\n/\\n/gs; $x }
 
-######################### End of black magic.
+our $DEBUG;
+sub debug { print "\t>>>",@_ if $DEBUG }
+sub esc   { my $x = shift||'<undef>'; $x =~ s/\n/\\n/gs; $x }
 
 ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
@@ -39,46 +22,49 @@
     elsif (!$str || $str =~ /\A#/)              { $neg = 0; next }
     my $setup_cmd = ($str =~ s/\A\{(.*)\}//) ? $1 : '';
     my $tests = 'sl';
+    my $orig_str = $str;
     $str =~ s/\\n/\n/g;
     my $orig = $str;
 
     eval $setup_cmd if $setup_cmd ne '';
+    is $@, '', 'no error';
     if($tests =~ /l/) {
         debug "\tUsing: $cmd\n";
         debug "\t   on: " . esc($setup_cmd) . "" . esc($str) . "\n";
         my @res;
         eval qq{\@res = $cmd; };
+        is $@, '', 'no error';
         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";
+        ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list");
     }
 
     eval $setup_cmd if $setup_cmd ne '';
+    is $@, '', 'no error';
     if($tests =~ /s/) {
         $str = $orig;
         debug "\tUsing: scalar $cmd\n";
         debug "\t   on: " . esc($str) . "\n";
         my $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";
+        ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar");
     }
 }
 
 # fails in Text::Balanced 1.95
 $_ = qq(s{}{});
 my @z = extract_quotelike();
-print "not " if $z0 eq '';
-print "ok ", $count++;
-print "\n";
+isnt $z0, '';
 
+@z = extract_quotelike("<<, 1; done()\nline1\nline2\n\n and next");
+like $z1, qr/\A,/, 'implied heredoc with ,' or do {
+  diag "error: '$@'\ngot: ", explain \@z;
+};
+
+done_testing;
 
 __DATA__
 
@@ -89,7 +75,6 @@
 'b';
 `cc`;
 
-
 <<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
      <<EOHERE; done();\nline1\nline2\nEOHERE\n; next;
 <<"EOHERE"; done()\nline1\nline2\nEOHERE\n and next

_service:tar_scm:Text-Balanced-2.04.tar.gz/t/07_exttag.t -> _service:tar_scm:Text-Balanced-2.06.tar.gz/t/07_exttag.t Changed

@@ -1,27 +1,12 @@
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
-
 use 5.008001;
 
 use strict;
 use warnings;
-
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-
-my $loaded = 0;
-BEGIN { $| = 1; print "1..53\n"; }
-END {print "not ok 1\n" unless $loaded;}
+use Test::More;
 use Text::Balanced qw ( extract_tagged gen_extract_tagged );
-$loaded = 1;
-print "ok 1\n";
-my $count=2;
-use vars qw( $DEBUG );
-sub debug { print "\t>>>",@_ if $DEBUG }
 
-######################### End of black magic.
+our $DEBUG;
+sub debug { print "\t>>>",@_ if $DEBUG }
 
 ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
@@ -34,30 +19,29 @@
     if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
     elsif ($str =~ /\A# THEISE? SHOULD FAIL/) { $neg = 1; next; }
     elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+    my $orig_str = $str;
     $str =~ s/\\n/\n/g;
     debug "\tUsing: $cmd\n";
     debug "\t   on: $str\n";
 
     my @res;
     my $var = eval "\@res = $cmd";
+    is $@, '', 'no error';
     debug "\t list got: " . join("|",map {defined $_ ? $_ : '<undef>'} @res) . "\n";
     debug "\t list left: $str\n";
-    print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list");
 
     pos $str = 0;
     $var = eval $cmd;
+    is $@, '', 'no error';
     $var = "<undef>" unless defined $var;
     debug "\t scalar got: $var\n";
     debug "\t scalar left: $str\n";
-    print "not " if ($str =~ '\A;')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar");
 }
 
+done_testing;
+
 __DATA__
 # USING: gen_extract_tagged("BEGIN(A-Z+)",'END$1',"(?s).*?(?=BEGIN)")->($str);
     ignore\n this and then BEGINHERE at the ENDHERE;

_service:tar_scm:Text-Balanced-2.04.tar.gz/t/08_extvar.t -> _service:tar_scm:Text-Balanced-2.06.tar.gz/t/08_extvar.t Changed

@@ -1,27 +1,12 @@
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
-
 use 5.008001;
 
 use strict;
 use warnings;
-
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-
-my $loaded = 0;
-BEGIN { $| = 1; print "1..183\n"; }
-END {print "not ok 1\n" unless $loaded;}
+use Test::More;
 use Text::Balanced qw ( extract_variable );
-$loaded = 1;
-print "ok 1\n";
-my $count=2;
-use vars qw( $DEBUG );
-sub debug { print "\t>>>",@_ if $DEBUG }
 
-######################### End of black magic.
+our $DEBUG;
+sub debug { print "\t>>>",@_ if $DEBUG }
 
 ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
@@ -34,30 +19,32 @@
     if ($str =~ s/\A# USING://) { $neg = 0; $cmd = $str; next; }
     elsif ($str =~ /\A# THEISE? SHOULD FAIL/) { $neg = 1; next; }
     elsif (!$str || $str =~ /\A#/) { $neg = 0; next }
+    my $orig_str = $str;
     $str =~ s/\\n/\n/g;
     debug "\tUsing: $cmd\n";
     debug "\t   on: $str\n";
 
     my @res;
     my $var = eval "\@res = $cmd";
+    is $@, '', 'no error';
     debug "\t list got: " . join("|",map {defined $_ ? $_ : '<undef>'} @res) . "\n";
     debug "\t list left: $str\n";
-    print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list");
 
     pos $str = 0;
     $var = eval $cmd;
+    is $@, '', 'no error';
     $var = "<undef>" unless defined $var;
     debug "\t scalar got: $var\n";
     debug "\t scalar left: $str\n";
-    print "not " if ($str =~ '\A;')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar");
 }
 
+my @res = extract_variable('${a}');
+is $res0, '${a}' or diag "error was: $@";
+
+done_testing;
+
 __DATA__
 
 # USING: extract_variable($str);

_service:tar_scm:Text-Balanced-2.04.tar.gz/t/09_gentag.t -> _service:tar_scm:Text-Balanced-2.06.tar.gz/t/09_gentag.t Changed

@@ -1,27 +1,12 @@
-# Before `make install' is performed this script should be runnable with
-# `make test'. After `make install' it should work as `perl test.pl'
-
 use 5.008001;
 
 use strict;
 use warnings;
-
-######################### We start with some black magic to print on failure.
-
-# Change 1..1 below to 1..last_test_to_print .
-# (It may become useful if the test is moved to ./t subdirectory.)
-
-my $loaded = 0;
-BEGIN { $| = 1; print "1..37\n"; }
-END {print "not ok 1\n" unless $loaded;}
 use Text::Balanced qw ( gen_extract_tagged );
-$loaded = 1;
-print "ok 1\n";
-my $count=2;
-use vars qw( $DEBUG );
-sub debug { print "\t>>>",@_ if $DEBUG }
+use Test::More;
 
-######################### End of black magic.
+our $DEBUG;
+sub debug { print "\t>>>",@_ if $DEBUG }
 
 ## no critic (BuiltinFunctions::ProhibitStringyEval)
 
@@ -31,6 +16,7 @@
 while (defined($str = <DATA>))
 {
     chomp $str;
+    my $orig_str = $str;
     $str =~ s/\\n/\n/g;
     if ($str =~ s/\A# USING://)
     {
@@ -41,6 +27,7 @@
                 local $SIG{__WARN__} = sub { push @warnings, shift; };
                 *f = eval $str || die;
         };
+        is $@, '', 'no error';
         next;
     }
     elsif ($str =~ /\A# THEISE? SHOULD FAIL/) { $neg = 1; next; }
@@ -51,24 +38,22 @@
 
     my @res;
     my $var = eval { @res = f($str) };
+    is $@, '', 'no error';
     debug "\t list got: " . join("|",map {defined $_ ? $_ : '<undef>'} @res) . "\n";
     debug "\t list left: $str\n";
-    print "not " if (substr($str,pos($str)||0,1) eq ';')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&isnt : \&is)->(substr($str,pos($str)||0,1), ';', "$orig_str matched list");
 
     pos $str = 0;
     $var = eval { scalar f($str) };
+    is $@, '', 'no error';
     $var = "<undef>" unless defined $var;
     debug "\t scalar got: $var\n";
     debug "\t scalar left: $str\n";
-    print "not " if ($str =~ '\A;')==$neg;
-    print "ok ", $count++;
-    print " ($@)" if $@ && $DEBUG;
-    print "\n";
+    ($neg ? \&unlike : \&like)->( $str, qr/\A;/, "$orig_str matched scalar");
 }
 
+done_testing;
+
 __DATA__
 
 # USING: gen_extract_tagged('{','}');

Changes of Revision 2