use strict;
use warnings;
+use Config;
use 5.010;
}
-plan tests => 214; # Update this when adding/deleting tests.
+plan tests => 447; # Update this when adding/deleting tests.
run_tests() unless caller;
+# test that runtime code without 'use re eval' is trapped
+
+sub norun {
+ like($@, qr/Eval-group not allowed at runtime/, @_);
+}
+
#
# Tests start here.
#
undef $@;
eval {/$c/};
- like($@, qr/not allowed at runtime/, $message);
+ norun("$message norun 1");
- use re "eval";
- /$a$c$a/;
- is($b, '14', $message);
+
+ {
+ eval {/$a$c$a/};
+ norun("$message norun 2");
+ use re "eval";
+ /$a$c$a/;
+ is($b, '14', $message);
+ }
our $lex_a = 43;
our $lex_b = 17;
is($lex_a, 44, $message);
is($lex_c, 43, $message);
- no re "eval";
undef $@;
- my $match = eval { /$a$c$a/ };
+ my $d = '(?{1})';
+ my $match = eval { /$a$c$a$d/ };
ok($@ && $@ =~ /Eval-group not allowed/ && !$match, $message);
is($b, '14', $message);
is(length qr /##/x, 9, "## in qr // doesn't corrupt memory; Bug 17776");
{
- use re 'eval';
ok "$x$x" =~ /^$x(??{$x})\z/,
"Postponed UTF-8 string in UTF-8 re matches UTF-8";
ok "$y$x" =~ /^$y(??{$x})\z/,
{
- use re 'eval';
- # Test if $^N and $+ work in (?{{})
+ # Test if $^N and $+ work in (?{})
our @ctl_n = ();
our @plus = ();
our $nested_tags;
}
{
- use re 'eval';
-
-
our $f;
local $f;
$f = sub {
is("@plus", $test->[3], "plus $c; Bug 56194");
is($str, $test->[4], "str $c; Bug 56194");
}
- SKIP: {
- if ($] le '5.010') {
- skip "test segfaults on perl < 5.10", 4;
- }
+ {
@ctl_n = ();
@plus = ();
local our $B = "J";
ok('(?{1})' =~ /^\Q(?{1})\E$/, '\Q(?{1})\E');
ok('(?{1})' =~ /^\Q(?{\E1\}\)$/, '\Q(?{\E1\}\)');
+ eval {/^\U(??{"$a\Ea"})$/ }; norun('^\U(??{"$a\Ea"})$ norun');
+ eval {/^\L(??{"$B\Ea"})$/ }; norun('^\L(??{"$B\Ea"})$ norun');
use re 'eval';
ok('Ia' =~ /^\U(??{"$a\Ea"})$/, '^\U(??{"$a\Ea"})$');
ok('ja' =~ /^\L(??{"$B\Ea"})$/, '^\L(??{"$B\Ea"})$');
# i.e. when do (?{}) blocks get (re)compiled, and what instances
# of lexical vars do they close over?
- # XXX remove this when TODOs are fixed
- # like ok, but 1st arg indicates TODO
- sub tok($$$) {
- my $todo = shift;
- local $::TODO = 're_eval lexical madness' if $todo;
- ok($_[0], $_[1]);
- }
+ # if the pattern string gets utf8 upgraded while concatenating,
+ # make sure a literal code block is still detected (by still
+ # compiling in the absence of use re 'eval')
- # XXX remove this when TODOs are fixed
- no warnings qw(uninitialized closure);
+ {
+ my $s1 = "\x{80}";
+ my $s2 = "\x{100}";
+ ok("\x{80}\x{100}" =~ /^$s1(?{1})$s2$/, "utf8 upgrade");
+ }
my ($cr1, $cr2, $cr3, $cr4);
- use re 'eval';
for my $x (qw(a b c)) {
my $bc = ($x ne 'a');
+ my $c80 = chr(0x80);
# the most basic: literal code should be in same scope
# as the parent
- tok(1, "A$x" =~ /^A(??{$x})$/, "[$x] literal code");
+ ok("A$x" =~ /^A(??{$x})$/, "[$x] literal code");
+ ok("\x{100}$x" =~ /^\x{100}(??{$x})$/, "[$x] literal code UTF8");
# the "don't recompile if pattern unchanged" mechanism
# shouldn't apply to code blocks - recompile every time
# to pick up new instances of variables
- my $code1 = 'B(??{$x})';
- tok($bc, "AB$x" =~ /^A$code1$/, "[$x] unvarying runtime code");
+ my $code1 = 'B(??{$x})';
+ my $code1u = $c80 . "\x{100}" . '(??{$x})';
+
+ eval {/^A$code1$/};
+ norun("[$x] unvarying runtime code AA norun");
+ eval {/^A$code1u$/};
+ norun("[$x] unvarying runtime code AU norun");
+ eval {/^$c80\x{100}$code1$/};
+ norun("[$x] unvarying runtime code UA norun");
+ eval {/^$c80\x{101}$code1u$/};
+ norun("[$x] unvarying runtime code UU norun");
+
+ {
+ use re 'eval';
+ ok("AB$x" =~ /^A$code1$/, "[$x] unvarying runtime code AA");
+ ok("A$c80\x{100}$x" =~ /^A$code1u$/,
+ "[$x] unvarying runtime code AU");
+ ok("$c80\x{100}B$x" =~ /^$c80\x{100}$code1$/,
+ "[$x] unvarying runtime code UA");
+ ok("$c80\x{101}$c80\x{100}$x" =~ /^$c80\x{101}$code1u$/,
+ "[$x] unvarying runtime code UU");
+ }
# mixed literal and run-time code blocks
- my $code2 = 'B(??{$x})';
- tok($bc, "A$x-B$x" =~ /^A(??{$x})-$code2$/, "[$x] literal+runtime");
+ my $code2 = 'B(??{$x})';
+ my $code2u = $c80 . "\x{100}" . '(??{$x})';
+
+ eval {/^A(??{$x})-$code2$/};
+ norun("[$x] literal+runtime AA norun");
+ eval {/^A(??{$x})-$code2u$/};
+ norun("[$x] literal+runtime AU norun");
+ eval {/^$c80\x{100}(??{$x})-$code2$/};
+ norun("[$x] literal+runtime UA norun");
+ eval {/^$c80\x{101}(??{$x})-$code2u$/};
+ norun("[$x] literal+runtime UU norun");
+
+ {
+ use re 'eval';
+ ok("A$x-B$x" =~ /^A(??{$x})-$code2$/,
+ "[$x] literal+runtime AA");
+ ok("A$x-$c80\x{100}$x" =~ /^A(??{$x})-$code2u$/,
+ "[$x] literal+runtime AU");
+ ok("$c80\x{100}$x-B$x" =~ /^$c80\x{100}(??{$x})-$code2$/,
+ "[$x] literal+runtime UA");
+ ok("$c80\x{101}$x-$c80\x{100}$x"
+ =~ /^$c80\x{101}(??{$x})-$code2u$/,
+ "[$x] literal+runtime UU");
+ }
# literal qr code only created once, naked
$cr1 //= qr/^A(??{$x})$/;
- tok(1, "Aa" =~ $cr1, "[$x] literal qr once naked");
+ ok("Aa" =~ $cr1, "[$x] literal qr once naked");
# literal qr code only created once, embedded with text
$cr2 //= qr/B(??{$x})$/;
- tok(0, "ABa" =~ /^A$cr2/, "[$x] literal qr once embedded text");
+ ok("ABa" =~ /^A$cr2/, "[$x] literal qr once embedded text");
# literal qr code only created once, embedded with text + lit code
$cr3 //= qr/C(??{$x})$/;
- tok($bc, "A$x-BCa" =~ /^A(??{$x})-B$cr3/,
+ ok("A$x-BCa" =~ /^A(??{$x})-B$cr3/,
"[$x] literal qr once embedded text + lit code");
# literal qr code only created once, embedded with text + run code
$cr4 //= qr/C(??{$x})$/;
my $code3 = 'A(??{$x})';
- tok(1, "A$x-BCa" =~ /^A$code3-B$cr4/,
+
+ eval {/^$code3-B$cr4/};
+ norun("[$x] literal qr once embedded text + run code norun");
+ {
+ use re 'eval';
+ ok("A$x-BCa" =~ /^$code3-B$cr4/,
"[$x] literal qr once embedded text + run code");
+ }
# literal qr code, naked
my $r1 = qr/^A(??{$x})$/;
- tok(1, "A$x" =~ $r1, "[$x] literal qr naked");
+ ok("A$x" =~ $r1, "[$x] literal qr naked");
# literal qr code, embedded with text
my $r2 = qr/B(??{$x})$/;
- tok($bc, "AB$x" =~ /^A$r2/, "[$x] literal qr embedded text");
+ ok("AB$x" =~ /^A$r2/, "[$x] literal qr embedded text");
# literal qr code, embedded with text + lit code
my $r3 = qr/C(??{$x})$/;
- tok($bc, "A$x-BC$x" =~ /^A(??{$x})-B$r3/,
+ ok("A$x-BC$x" =~ /^A(??{$x})-B$r3/,
"[$x] literal qr embedded text + lit code");
# literal qr code, embedded with text + run code
my $r4 = qr/C(??{$x})$/;
my $code4 = '(??{$x})';
- tok($bc, "A$x-BC$x" =~ /^A$code4-B$r4/,
+
+ eval {/^A$code4-B$r4/};
+ norun("[$x] literal qr embedded text + run code");
+ {
+ use re 'eval';
+ ok("A$x-BC$x" =~ /^A$code4-B$r4/,
"[$x] literal qr embedded text + run code");
+ }
# nested qr in different scopes
my $code5 = '(??{$x})';
- my $r5 = qr/C(??{$x})$/;
- my $r6 = qr/$code5-C(??{$x})$/;
+ my $r5 = qr/C(??{$x})/;
+
+ my $r6;
+ eval {qr/$code5-C(??{$x})/}; norun("r6 norun");
+ {
+ use re 'eval';
+ $r6 = qr/$code5-C(??{$x})/;
+ }
my @rr5;
my @rr6;
my $rr5 = qr/^A(??{"$x$y"})-$r5/;
push @rr5, $rr5;
- tok("$x$y" ne "ad", "A$x$y-C$x" =~ $rr5,
+ ok("A$x$y-C$x" =~ $rr5,
"[$x-$y] literal qr + r5");
my $rr6 = qr/^A(??{"$x$y"})-$r6/;
push @rr6, $rr6;
- tok("$x$y" ne "ad", "A$x$y-$x-C$x" =~ $rr6,
+ ok("A$x$y-$x-C$x" =~ $rr6,
"[$x-$y] literal qr + r6");
}
my $y = 'Y';
my $yy = (qw(d e f))[$i];
my $rr5 = $rr5[$i];
- tok("$x$yy" ne "ad", "A$x$yy-C$x" =~ $rr5,
- "[$x-$yy] literal qr + r5, outside");
- tok(1, "A$x$yy-C$x-D$x" =~ /$rr5-D(??{$x})/,
+ ok("A$x$yy-C$x" =~ $rr5, "[$x-$yy] literal qr + r5, outside");
+ ok("A$x$yy-C$x-D$x" =~ /$rr5-D(??{$x})$/,
"[$x-$yy] literal qr + r5 + lit, outside");
+
my $rr6 = $rr6[$i];
push @rr6, $rr6;
- tok("$x$yy" ne "ad", "A$x$yy-$x-C$x" =~ $rr6,
+ ok("A$x$yy-$x-C$x" =~ $rr6,
"[$x-$yy] literal qr + r6, outside");
- tok(1, "A$x$yy-$x-C$x-D$x" =~ /$rr6-D(??{$x})/,
+ ok("A$x$yy-$x-C$x-D$x" =~ /$rr6-D(??{$x})/,
"[$x-$yy] literal qr + r6 +lit, outside");
}
}
+
+ # recursive subs should get lexical from the correct pad depth
+
+ sub recurse {
+ my ($n) = @_;
+ return if $n > 2;
+ ok("A$n" =~ /^A(??{$n})$/, "recurse($n)");
+ recurse($n+1);
+ }
+ recurse(0);
+
+ # for qr// containing run-time elements but with a compile-time
+ # code block, make sure the run-time bits are executed in the same
+ # pad they were compiled in
+ {
+ my $a = 'a'; # ensure outer and inner pads don't align
+ my $b = 'b';
+ my $c = 'c';
+ my $d = 'd';
+ my $r = qr/^$b(??{$c})$d$/;
+ ok("bcd" =~ $r, "qr with run-time elements and code block");
+ }
+
+ # check that cascaded embedded regexes all see their own lexical
+ # environment
+
+ {
+ my ($r1, $r2, $r3, $r4);
+ my ($x1, $x2, $x3, $x4) = (5,6,7,8);
+ { my $x1 = 1; $r1 = qr/A(??{$x1})/; }
+ { my $x2 = 2; $r2 = qr/$r1(??{$x2})/; }
+ { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; }
+ { my $x4 = 4; $r4 = qr/$r3(??{$x4})/; }
+ ok("A1234" =~ /^$r4$/, "cascaded qr");
+ }
+
+ # and again, but in a loop, with no external references
+ # being maintained to the qr's
+
+ {
+ my $r = 'A';
+ for my $x (1..4) {
+ $r = qr/$r(??{$x})/;
+ }
+ my $x = 5;
+ ok("A1234" =~ /^$r$/, "cascaded qr loop");
+ }
+
+
+ # and again, but compiling the qrs in an eval so there
+ # aren't even refs to the qrs from any ops
+
+ {
+ my $r = 'A';
+ for my $x (1..4) {
+ $r = eval q[ qr/$r(??{$x})/; ];
+ }
+ my $x = 5;
+ ok("A1234" =~ /^$r$/, "cascaded qr loop");
+ }
+
+ # have qrs with either literal code blocks or only embedded
+ # code blocks, but not both
+
+ {
+ my ($r1, $r2, $r3, $r4);
+ my ($x1, $x3) = (7,8);
+ { my $x1 = 1; $r1 = qr/A(??{$x1})/; }
+ { $r2 = qr/${r1}2/; }
+ { my $x3 = 3; $r3 = qr/$r2(??{$x3})/; }
+ { $r4 = qr/${r3}4/; }
+ ok("A1234" =~ /^$r4$/, "cascaded qr mix 1");
+ ok("A12345" =~ /^${r4}5$/, "cascaded qr mix 2");
+ ok("A1234" =~ qr/^$r4$/ , "cascaded qr mix 3");
+ ok("A12345" =~ qr/^${r4}5$/, "cascaded qr mix 4");
+ }
+
+ # and make sure things are freed at the right time
+
+ SKIP: {
+ if ($Config{mad}) {
+ skip "MAD doesn't free eval CVs", 3;
+ }
+
+ {
+ sub Foo99::DESTROY { $Foo99::d++ }
+ $Foo99::d = 0;
+ my $r1;
+ {
+ my $x = bless [1], 'Foo99';
+ $r1 = eval 'qr/(??{$x->[0]})/';
+ }
+ my $r2 = eval 'qr/a$r1/';
+ my $x = 2;
+ ok(eval '"a1" =~ qr/^$r2$/', "match while in scope");
+ # make sure PL_reg_curpm isn't holding on to anything
+ "a" =~ /a(?{1})/;
+ is($Foo99::d, 0, "before scope exit");
+ }
+ ::is($Foo99::d, 1, "after scope exit");
+ }
+
+ # forward declared subs should Do The Right Thing with any anon CVs
+ # within them (i.e. pad_fixup_inner_anons() should work)
+
+ sub forward;
+ sub forward {
+ my $x = "a";
+ my $A = "A";
+ ok("Aa" =~ qr/^A(??{$x})$/, "forward qr compiletime");
+ ok("Aa" =~ qr/^$A(??{$x})$/, "forward qr runtime");
+ }
+ forward;
}
+ # test that run-time embedded code, when re-fed into toker,
+ # does all the right escapes
+
+ {
+ my $enc = eval 'use Encode; find_encoding("ascii")';
+
+ my $x = 0;
+ my $y = 'bad';
+
+ # note that most of the strings below are single-quoted, and the
+ # things within them, like '$y', *aren't* intended to interpolate
+
+ my $s1 =
+ 'a\\$y(?# (??{BEGIN{$x=1} "X1"})b(?# \Ux2\E)c\'d\\\\e\\\\Uf\\\\E';
+
+ ok(q{a$ybc'd\e\Uf\E} =~ /^$s1$/, "reparse");
+ is($x, 0, "reparse no BEGIN");
+
+ my $s2 = 'g\\$y# (??{{BEGIN{$x=2} "X3"}) \Ux3\E' . "\nh";
+
+ ok(q{a$ybc'd\\e\\Uf\\Eg$yh} =~ /^$s1$s2$/x, "reparse /x");
+ is($x, 0, "reparse /x no BEGIN");
+
+ my $b = '\\';
+ my $q = '\'';
+
+ # non-ascii in string as "<0xNNN>"
+ sub esc_str {
+ my $s = shift;
+ $s =~ s{(.)}{
+ my $c = ord($1);
+ ($c< 32 || $c > 127) ? sprintf("<0x%x>", $c) : $1;
+ }ge;
+ $s;
+ }
+ sub fmt { sprintf "hairy backslashes %s [%s] =~ /^%s/",
+ $_[0], esc_str($_[1]), esc_str($_[2]);
+ }
+
+
+ for my $u (
+ [ '', '', 'blank ' ],
+ [ "\x{100}", '\x{100}', 'single' ],
+ [ "\x{100}", "\x{100}", 'double' ])
+ {
+ for my $pair (
+ [ "$b", "$b$b" ],
+ [ "$q", "$q" ],
+ [ "$b$q", "$b$b$b$q" ],
+ [ "$b$b$q", "$b$b$b$b$q" ],
+ [ "$b$b$b$q", "$b$b$b$b$b$b$q" ],
+ [ "$b$b$b$b$q","$b$b$b$b$b$b$b$b$q" ],
+ ) {
+ my ($s, $r) = @$pair;
+ $s = "9$s";
+ my $ss = "$u->[0]$s";
+
+ my $c = '9' . $r;
+ my $cc = "$u->[1]$c";
+
+ ok($ss =~ /^$cc/, fmt("plain $u->[2]", $ss, $cc));
+
+ no strict;
+ my $chr41 = "\x41";
+ $ss = "$u->[0]\t${q}$chr41${b}x42$s";
+ $nine = $nine = "bad";
+ for my $use_qr ('', 'qr') {
+ $c = qq[(??{my \$z='{';]
+ . qq[$use_qr"$b${b}t$b$q$b${b}x41$b$b$b${b}x42"]
+ . qq[. \$nine})];
+ # (??{ qr/str/ }) goes through one less interpolation
+ # stage than (??{ qq/str/ })
+ $c =~ s{\\\\}{\\}g if ($use_qr eq 'qr');
+ $c .= $r;
+ $cc = "$u->[1]$c";
+ my $nine = 9;
+
+ eval {/^$cc/}; norun(fmt("code norun $u->[2]", $ss, $cc));
+ {
+ use re 'eval';
+ ok($ss =~ /^$cc/, fmt("code $u->[2]", $ss, $cc));
+ }
+
+ {
+ # Poor man's "use encoding 'ascii'".
+ # This causes a different code path in S_const_str()
+ # to be used
+ local ${^ENCODING} = $enc;
+ use re 'eval';
+ ok($ss =~ /^$cc/, fmt("encode $u->[2]", $ss, $cc));
+ }
+ }
+ }
+ }
+
+ my $code1u = "(??{qw(\x{100})})";
+ eval {/^$code1u$/}; norun("reparse embeded unicode norun");
+ {
+ use re 'eval';
+ ok("\x{100}" =~ /^$code1u$/, "reparse embeded unicode");
+ }
+ }
+
+ # a non-pattern literal won't get code blocks parsed at compile time;
+ # but they must get parsed later on if 'use re eval' is in scope
+ # also check that unbalanced {}'s are parsed ok
+
+ {
+ eval q["a{" =~ '^(??{"a{"})$'];
+ norun("non-pattern literal code norun");
+ eval {/^${\'(??{"a{"})'}$/};
+ norun("runtime code with unbalanced {} norun");
+
+ use re 'eval';
+ ok("a{" =~ '^(??{"a{"})$', "non-pattern literal code");
+ ok("a{" =~ /^${\'(??{"a{"})'}$/, "runtime code with unbalanced {}");
+ }
+
+ # make sure warnings come from the right place
+
+ {
+ use warnings;
+ my ($s, $t, $w);
+ local $SIG{__WARN__} = sub { $w .= "@_" };
+
+ $w = ''; $s = 's';
+ my $r = qr/(?{$t=$s+1})/;
+ "a" =~ /a$r/;
+ like($w, qr/pat_re_eval/, "warning main file");
+
+ # do it in an eval to get predictable line numbers
+ eval q[
+
+ $r = qr/(?{$t=$s+1})/;
+ ];
+ $w = ''; $s = 's';
+ "a" =~ /a$r/;
+ like($w, qr/ at \(eval \d+\) line 3/, "warning eval A");
+
+ $w = ''; $s = 's';
+ eval q[
+ use re 'eval';
+ my $c = '(?{$t=$s+1})';
+ "a" =~ /a$c/;
+ 1;
+ ];
+ like($w, qr/ at \(eval \d+\) line 1/, "warning eval B");
+ }
+
+ # jumbo test for:
+ # * recursion;
+ # * mixing all the different types of blocks (literal, qr/literal/,
+ # runtime);
+ # * backtracking (the Z+ alternation ensures CURLYX and full
+ # scope popping on backtracking)
+
+ {
+ sub recurse2 {
+ my ($depth)= @_;
+ return unless $depth;
+ my $s1 = '3-LMN';
+ my $r1 = qr/(??{"$s1-$depth"})/;
+
+ my $s2 = '4-PQR';
+ my $c1 = '(??{"$s2-$depth"})';
+ use re 'eval';
+ ok( "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>"
+ . "<12345-ABC-$depth-123-LMN-$depth-1234-PQR-$depth>"
+ =~
+ /^<(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>
+ <(\d|Z+)+(??{"45-ABC-$depth-"})(\d|Z+)+$r1-\d+$c1>$/x,
+ "recurse2($depth)");
+ recurse2($depth-1);
+ }
+ 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
+
+ {
+ use re 'eval';
+
+ my $code = '(?{$x=})';
+ eval { "a" =~ /^a$code/ };
+ like($@, qr/syntax error at \(eval \d+\) line \d+/, 'syntax error');
+
+ $code = '(?{BEGIN{die})';
+ eval { "a" =~ /^a$code/ };
+ like($@,
+ qr/BEGIN failed--compilation aborted at \(eval \d+\) line \d+/,
+ '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 })');
+ }
+
+
} # End of sub run_tests
1;
https://perl5.git.perl.org / perl5.git / blobdiff