avoid 'unescaped left brace' warnings

[perl5.git] / t / re / pat_re_eval.t

diff --git a/t/re/pat_re_eval.t b/t/re/pat_re_eval.t
index 20dbf06..1d724c2 100644 (file)
--- a/t/re/pat_re_eval.t
+++ b/t/re/pat_re_eval.t
@@ -23,7 +23,7 @@ BEGIN {
 }
 
 
-plan tests => 434;  # Update this when adding/deleting tests.
+plan tests => 454;  # Update this when adding/deleting tests.
 
 run_tests() unless caller;
 
@@ -772,8 +772,8 @@ sub run_tests {
        norun("runtime code with unbalanced {} norun");
 
        use re 'eval';
-       ok("a{" =~ '^(??{"a{"})$', "non-pattern literal code");
-       ok("a{" =~ /^${\'(??{"a{"})'}$/, "runtime code with unbalanced {}");
+       ok("a{" =~ '^a(??{"{"})$', "non-pattern literal code");
+       ok("a{" =~ /^a${\'(??{"{"})'}$/, "runtime code with unbalanced {}");
     }
 
     # make sure warnings come from the right place
@@ -835,6 +835,88 @@ sub run_tests {
        recurse2(5);
     }
 
+    # nested (??{}) called from various levels of a recursive function
+
+    {
+       sub recurse3 {
+           my ($n) = @_;
+           return if $n > 3;
+           ok("A$n" =~ m{^A(??{ "0123" =~ /((??{$n}))/; $1 })$},
+               "recurse3($n)");
+           ok("A$n" !~ m{^A(??{ "0123" =~ /((??{$n}))/; "X" })$},
+               "recurse3($n) nomatch");
+           recurse3($n+1);
+       }
+       recurse3(0);
+    }
+
+    # nested (??{}) being invoked recursively via a function
+
+    {
+       my $s = '';
+       our $recurse4;
+       my @alpha = qw(A B C D E);
+       $recurse4 = sub {
+           my ($n) = @_;
+           $s .= "(n=$n:";
+           if ($n < 4) {
+               my $m = ("$alpha[$n]" . substr("0123", 0, $n+1)) =~
+                   m{^([A-Z])
+                     (??{
+                           $s .= "1=$1:";
+                           "$n-0123" =~ m{^(\d)-(((??{$recurse4->($n+1)})))};
+                           $s .= "i1=$1:<=[$2]";
+                           $3; # NB - not stringified
+                      })
+                      $
+                    }x;
+               $s .= "1a=$1:";
+               $s .= $m ? 'M' : '!M';
+           }
+           my $ret =  '.*?' . ($n-1);
+           $s .= "<=[$ret])";
+           return $ret;
+       };
+       $recurse4->(0);
+       my $exp =   '(n=0:1=A:(n=1:1=B:(n=2:1=C:(n=3:1=D:(n=4:<=[.*?3])'
+                 . 'i1=3:<=[0123]1a=D:M<=[.*?2])i1=2:<=[012]1a=C:M<=[.*?1])'
+                 . 'i1=1:<=[01]1a=B:M<=[.*?0])i1=0:<=[0]1a=A:M<=[.*?-1])';
+       is($s, $exp, 'recurse4');
+    }
+
+    # single (??{}) being invoked recursively via a function
+
+    {
+       my $s = '';
+       our $recurse5;
+       my @alpha = qw(A B C D E);
+       $recurse5 = sub {
+           my ($n) = @_;
+           $s .= "(n=$n:";
+           if ($n < 4) {
+               my $m = ("$alpha[$n]" . substr("0123", 0, $n+1)) =~
+                   m{^([A-Z])
+                     ((??{
+                           $s .= "1=$1:";
+                           $recurse5->($n+1);
+                      }))
+                      $
+                    }x;
+               $s .= "1a=$1:2=$2:";
+               $s .= $m ? 'M' : '!M';
+           }
+           my $ret =  '.*?' . ($n-1);
+           $s .= "<=[$ret])";
+           return $ret;
+       };
+       $recurse5->(0);
+       my $exp =   '(n=0:1=A:(n=1:1=B:(n=2:1=C:(n=3:1=D:(n=4:<=[.*?3])'
+                 . '1a=D:2=0123:M<=[.*?2])1a=C:2=012:M<=[.*?1])'
+                 . '1a=B:2=01:M<=[.*?0])1a=A:2=0:M<=[.*?-1])';
+       is($s, $exp, 'recurse5');
+    }
+
+
     # make sure that errors during compiling run-time code get trapped
 
     {
@@ -851,6 +933,59 @@ sub run_tests {
            'syntax error');
     }
 
+    # make sure that 'use re eval' is propagated into compiling the
+    # pattern returned by (??{})
+
+    {
+       use re 'eval';
+       my $pat = 'B(??{1})C';
+       my $A = 'A';
+       # compile-time outer code-block
+       ok("AB1CD" =~ /^A(??{$pat})D$/, "re eval propagated compile-time");
+       # run-time outer code-block
+       ok("AB1CD" =~ /^$A(??{$pat})D$/, "re eval propagated run-time");
+    }
+
+    # returning a ref to something that had set magic but wasn't
+    # PERL_MAGIC_qr triggered a false positive assertion failure
+    # The test is not so much concerned with it not matching,
+    # as with not failing the assertion
+
+    {
+       ok("a" !~ /^(a)(??{ \$1 })/, '(??{ ref })');
+    }
+
+    # make sure the uninit warning from returning an undef var
+    # sees the right var
+
+    {
+       my ($u1, $u2);
+       my $warn = '';
+       local $SIG{__WARN__} = sub {  $warn .= $_[0] };
+       $u1 =~ /(??{$u2})/ or die;
+       like($warn, qr/value \$u1 in pattern match.*\n.*value at/, 'uninit');
+    }
+
+    # test that code blocks are called in scalar context
+
+    {
+       my @a = (0);
+       ok("" =~ /^(?{@a})$/, '(?{}) in scalar context');
+       is($^R, 1, '(?{}) in scalar context: $^R');
+       ok("1" =~ /^(??{@a})$/, '(??{}) in scalar context');
+       ok("foo" =~ /^(?(?{@a})foo|bar)$/, '(?(?{})|) in scalar context');
+    }
+
+    # BEGIN in compiled blocks shouldn't mess with $1 et al
+
+    {
+       use re 'eval';
+       my $code1 = '(B)(??{ BEGIN { "X" =~ /X/ } $1})(C)';
+       ok("ABBCA" =~ /^(.)(??{$code1})\1$/, '(?{}) BEGIN and $1');
+       my $code2 = '(B)(??{ BEGIN { "X" =~ /X/ } $1 =~ /(.)/ ? $1 : ""})(C)';
+       ok("ABBCA" =~ /^(.)(??{$code2})\1$/, '(?{}) BEGIN and $1 mark 2');
+    }
+
 
 } # End of sub run_tests