BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.');
- require './test.pl';
- skip_all_if_miniperl("no dynamic loading on miniperl, no re");
+ require './test.pl'; require './charset_tools.pl';
+ set_up_inc('../lib');
}
-plan tests => 355; # Update this when adding/deleting tests.
+plan tests => 527; # 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 $d = '(?{1})';
my $match = eval { /$a$c$a$d/ };
ok 'goodfood' =~ $a, "Reblessed qr // matches";
is($a, '(?^:foo)', "Reblessed qr // stringifies");
my $x = "\x{3fe}";
- my $z = my $y = "\317\276"; # Byte representation of $x
+ my $z = my $y = byte_utf8a_to_utf8n("\317\276"); # Byte representation
+ # of $x
$a = qr /$x/;
ok $x =~ $a, "UTF-8 interpolation in qr //";
ok "a$a" =~ $x, "Stringified qr // preserves UTF-8";
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 = ();
is("@ctl_n", "1 2 undef", 'Bug 56194');
is("@plus", "1 2 undef", 'Bug 56194');
is($str,
- "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = undef",
- 'Bug 56194');
+ "\$1 = undef, \$2 = undef, \$3 = undef, \$4 = undef, \$5 = undef, \$^R = 3",
+ 'Bug 56194 ($^R tweaked by 121070)');
+ }
+ {
+ undef $^R;
+ "abcd"=~/(?<Char>.)(?&Char)(?{ 42 })/;
+ is("$^R", 42, 'Bug 121070 - use of (?&Char) should not clobber $^R');
+ "abcd"=~/(?<Char>.)(?&Char)(?{ 42 })(?{ 43 })/;
+ is("$^R", 43, 'related to 121070 - use of (?&Char) should not clobber $^R');
}
}
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"})$');
# shouldn't apply to code blocks - recompile every time
# to pick up new instances of variables
- use re 'eval';
-
my $code1 = 'B(??{$x})';
my $code1u = $c80 . "\x{100}" . '(??{$x})';
- 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");
+
+ 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})';
my $code2u = $c80 . "\x{100}" . '(??{$x})';
- 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");
-
- no re 'eval';
+
+ 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
$cr4 //= qr/C(??{$x})$/;
my $code3 = 'A(??{$x})';
- use re 'eval';
- ok("A$x-BCa" =~ /^$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");
- no re 'eval';
+ }
# literal qr code, naked
my $r4 = qr/C(??{$x})$/;
my $code4 = '(??{$x})';
- use re 'eval';
- ok("A$x-BC$x" =~ /^A$code4-B$r4/,
- "[$x] literal qr embedded text + run code");
- no re 'eval';
-
+ eval {/^A$code4-B$r4/};
+ norun("[$x] literal qr embedded text + run code");
{
- eval { "A$x-BC$x" =~ /^A$code4-B$r4/ };
- like($@, qr/Eval-group not allowed/, "runtime code5");
+ 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})/;
- use re 'eval';
- my $r6 = qr/$code5-C(??{$x})/;
- no re 'eval';
+ my $r6;
+ eval {qr/$code5-C(??{$x})/}; norun("r6 norun");
+ {
+ use re 'eval';
+ $r6 = qr/$code5-C(??{$x})/;
+ }
my @rr5;
my @rr6;
}
# 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;
{
- 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");
+ my $x = bless [1], 'Foo99';
+ $r1 = eval 'qr/(??{$x->[0]})/';
}
- ::is($Foo99::d, 1, "after scope exit");
+ 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)
# does all the right escapes
{
- use re 'eval';
-
- my $enc = eval 'use Encode; find_encoding("ascii")';
+ my $enc;
+ $enc = eval 'use Encode; find_encoding("ascii")' unless $::IS_EBCDIC;
my $x = 0;
my $y = 'bad';
my $s = shift;
$s =~ s{(.)}{
my $c = ord($1);
- ($c< 32 || $c > 127) ? sprintf("<0x%x>", $c) : $1;
+ (utf8::native_to_unicode($c)< 32
+ || utf8::native_to_unicode($c) > 127)
+ ? sprintf("<0x%x>", $c) : $1;
}ge;
$s;
}
my $c = '9' . $r;
my $cc = "$u->[1]$c";
- ok($ss =~ /^$cc/, fmt("plain $u->[2]", $ss, $cc));
+
+ 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";
+ $ss = "$u->[0]\t${q}\x41${b}x42$s" if $::IS_ASCII;
+ $ss = "$u->[0]\t${q}\xC1${b}xC2$s" if $::IS_EBCDIC;
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"]
+ . (($::IS_ASCII)
+ ? qq[$use_qr"$b${b}t$b$q$b${b}x41$b$b$b${b}x42"]
+ : qq[$use_qr"$b${b}t$b$q$b${b}xC1$b$b$b${b}xC2"])
. qq[. \$nine})];
# (??{ qr/str/ }) goes through one less interpolation
# stage than (??{ qq/str/ })
$c .= $r;
$cc = "$u->[1]$c";
my $nine = 9;
- ok($ss =~ /^$cc/, fmt("code $u->[2]", $ss, $cc));
+
+ eval {/^$cc/}; norun(fmt("code norun $u->[2]", $ss, $cc));
+ {
+ use re 'eval';
+ ok($ss =~ /^$cc/, fmt("code $u->[2]", $ss, $cc));
+ }
+
+ SKIP:
{
+ skip("Encode not working on EBCDIC", 1) unless defined $enc;
# Poor man's "use encoding 'ascii'".
# This causes a different code path in S_const_str()
# to be used
+ no warnings 'deprecated';
local ${^ENCODING} = $enc;
- ok($ss =~ /^$cc/, fmt("encode $u->[2]", $ss, $cc));
+ use warnings 'deprecated';
+ use re 'eval';
+ ok($ss =~ /^$cc/, fmt("encode $u->[2]", $ss, $cc));
}
}
}
}
my $code1u = "(??{qw(\x{100})})";
- ok("\x{100}" =~ /^$code1u$/, "reparse embeded unicode");
+ eval {/^$code1u$/}; norun("reparse embedded unicode norun");
+ {
+ use re 'eval';
+ ok("\x{100}" =~ /^$code1u$/, "reparse embedded unicode");
+ }
}
# a non-pattern literal won't get code blocks parsed at compile time;
# 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 {}");
+ ok("a{" =~ '^a(??{"{"})$', "non-pattern literal code");
+ ok("a{" =~ /^a${\'(??{"{"})'}$/, "runtime code with unbalanced {}");
}
# make sure warnings come from the right place
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');
+
+ use utf8;
+ $code = '(?{Ｆｏｏ::$bar})';
+ eval { "a" =~ /^a$code/ };
+ like($@, qr/Bad name after Ｆｏｏ:: at \(eval \d+\) line \d+/, 'UTF8 sytax 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');
+ }
+
+ # check that the optimiser is applied to code blocks: see if aelem has
+ # been converted to aelemfast
+
+ {
+ my $out;
+ for my $prog (
+ '/(?{$a[0]})/',
+ 'q() =~ qr/(?{$a[0]})/',
+ 'use re q(eval); q() =~ q{(?{$a[0]})}',
+ 'use re q(eval); $c = q{(?{$a[0]})}; /$c/',
+ 'use re q(eval); $c = q{(?{$a[0]})}; /(?{1;})$c/',
+ ) {
+ $out = runperl(switches => ["-Dt"], prog => $prog, stderr => 1);
+ like($out, qr/aelemfast|Recompile perl with -DDEBUGGING/,
+ "optimise: '$prog'");
+ }
+ }
+
+ # [perl #115080]
+ # Ensure that ?pat? matches exactly once, even when the run-time
+ # pattern changes, and even when the presence of run-time (?{}) affects
+ # how and when patterns are recompiled
+
+ {
+ my $m;
+
+ $m = '';
+ for (qw(a a a)) {
+ $m .= $_ if m?$_?;
+ }
+ is($m, 'a', '?pat? with a,a,a');
+
+ $m = '';
+ for (qw(a b c)) {
+ $m .= $_ if m?$_?;
+ }
+ is($m, 'a', '?pat? with a,b,c');
+
+ use re 'eval';
+
+ $m = '';
+ for (qw(a a a)) {
+ my $e = qq[(??{"$_"})];
+ $m .= $_ if m?$e?;
+ }
+ is($m, 'a', '?pat? with (??{a,a,a})');
+
+ $m = '';
+ for (qw(a b c)) {
+ my $e = qq[(??{"$_"})];
+ $m .= $_ if m?$e?;
+ }
+ is($m, 'a', '?pat? with (??{a,b,c})');
+ }
+
+ {
+ # this code won't actually fail, but it used to fail valgrind,
+ # so its here just to make sure valgrind doesn't fail again
+ # While examining the ops of the secret anon sub wrapped around
+ # the qr//, the pad of the sub was in scope, so cSVOPo_sv
+ # got the const from the wrong pad. By having lots of $s's
+ # (aka gvsv(*s), this forces the targs of the consts which have
+ # been moved to the pad, to have high indices.
+
+ sub {
+ local our $s = "abc";
+ my $qr = qr/^(?{1})$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s$s/;
+ }->();
+ pass("cSVOPo_sv");
+ }
+
+ # [perl #115004]
+ # code blocks in qr objects that are interpolated in arrays need
+ # handling the same as if they were interpolated from scalar vars
+ # (before this code would need 'use re "eval"')
+
+ {
+ use Tie::Array;
+
+ use vars '@global';
+ local @global;
+ my @array;
+ my @refs = (0, \@array, 2);
+ my @tied;
+ tie @tied, 'Tie::StdArray';
+ {
+ my $bb = 'B';
+ my $dd = 'D';
+ @array = ('A', qr/(??{$bb})/, 'C', qr/(??{$dd})/, 'E');
+ @tied = @array;
+ @global = @array;
+ }
+ my $bb = 'X';
+ my $dd = 'Y';
+ ok("A B C D E=" =~ /@array/, 'bare interpolated array match');
+ ok("A B C D E=" =~ qr/@array/, 'qr bare interpolated array match');
+ ok("A B C D E=" =~ /@global/, 'bare interpolated global array match');
+ ok("A B C D E=" =~ qr/@global/,
+ 'qr bare interpolated global array match');
+ ok("A B C D E=" =~ /@{$refs[1]}/, 'bare interpolated ref array match');
+ ok("A B C D E=" =~ qr/@{$refs[1]}/,
+ 'qr bare interpolated ref array match');
+ ok("A B C D E=" =~ /@tied/, 'bare interpolated tied array match');
+ ok("A B C D E=" =~ qr/@tied/, 'qr bare interpolated tied array match');
+ ok("aA B C D E=" =~ /^a@array=$/, 'interpolated array match');
+ ok("aA B C D E=" =~ qr/^a@array=$/, 'qr interpolated array match');
+ ok("aA B C D E=" =~ /^a@global=$/, 'interpolated global array match');
+ ok("aA B C D E=" =~ qr/^a@global=$/,
+ 'qr interpolated global array match');
+ ok("aA B C D E=" =~ /^a@{$refs[1]}=$/, 'interpolated ref array match');
+ ok("aA B C D E=" =~ qr/^a@{$refs[1]}=$/,
+ 'qr interpolated ref array match');
+ ok("aA B C D E=" =~ /^a@tied=$/, 'interpolated tied array match');
+ ok("aA B C D E=" =~ qr/^a@tied=$/, 'qr interpolated tied array match');
+
+ {
+ local $" = '-';
+ ok("aA-B-C-D-E=" =~ /^a@{array}=$/,
+ 'interpolated array match with local sep');
+ ok("aA-B-C-D-E=" =~ qr/^a@{array}=$/,
+ 'qr interpolated array match with local sep');
+ ok("aA-B-C-D-E=" =~ /^a@{global}=$/,
+ 'interpolated global array match with local sep');
+ ok("aA-B-C-D-E=" =~ qr/^a@{global}=$/,
+ 'qr interpolated global array match with local sep');
+ ok("aA-B-C-D-E=" =~ /^a@{tied}=$/,
+ 'interpolated tied array match with local sep');
+ ok("aA-B-C-D-E=" =~ qr/^a@{tied}=$/,
+ 'qr interpolated tied array match with local sep');
+ }
+
+ # but don't handle the array ourselves in the presence of \Q etc
+
+ @array = ('A', '(?{})');
+ @global = @array;
+ @tied = @array;
+ ok("aA (?{})=" =~ /^a\Q@{array}\E=$/,
+ 'interpolated array match with \Q');
+ ok("aA (?{})=" =~ qr/^a\Q@{array}\E=$/,
+ 'qr interpolated array match with \Q');
+ ok("aA (?{})=" =~ /^a\Q@{global}\E=$/,
+ 'interpolated global array match with \Q');
+ ok("aA (?{})=" =~ qr/^a\Q@{global}\E=$/,
+ 'qr interpolated global array match with \Q');
+ ok("aA (?{})=" =~ /^a\Q@{$refs[1]}\E=$/,
+ 'interpolated ref array match with \Q');
+ ok("aA (?{})=" =~ qr/^a\Q@{$refs[1]}\E=$/,
+ 'qr interpolated ref array match with \Q');
+ ok("aA (?{})=" =~ /^a\Q@{tied}\E=$/,
+ 'interpolated tied array match with \Q');
+ ok("aA (?{})=" =~ qr/^a\Q@{tied}\E=$/,
+ 'qr interpolated tied array match with \Q');
+
+ # and check it works with an empty array
+
+ @array = ();
+ @global = ();
+ @tied = ();
+ ok("a=" =~ /^a@array=$/, 'empty array match');
+ ok("a=" =~ qr/^a@array=$/, 'qr empty array match');
+ ok("a=" =~ /^a@global=$/, 'empty global array match');
+ ok("a=" =~ qr/^a@global=$/, 'qr empty global array match');
+ ok("a=" =~ /^a@tied=$/, 'empty tied array match');
+ ok("a=" =~ qr/^a@tied=$/, 'qr empty tied array match');
+ ok("a=" =~ /^a\Q@{array}\E=$/, 'empty array match with \Q');
+ ok("a=" =~ /^a\Q@{array}\E=$/, 'empty array match with \Q');
+ ok("a=" =~ qr/^a\Q@{global}\E=$/,
+ 'qr empty global array match with \Q');
+ ok("a=" =~ /^a\Q@{tied}\E=$/, 'empty tied array match with \Q');
+ ok("a=" =~ qr/^a\Q@{tied}\E=$/, 'qr empty tied array match with \Q');
+
+ # NB: these below are empty patterns, so they happen to use the
+ # successful match from the line above
+
+ ok("a=" =~ /@array/, 'empty array pattern');
+ ok("a=" =~ qr/@array/, 'qr empty array pattern');
+ ok("a=" =~ /@global/, 'empty global array pattern');
+ ok("a=" =~ qr/@global/, 'qr empty global array pattern');
+ ok("a=" =~ /@tied/, 'empty tied pattern');
+ ok("a=" =~ qr/@tied/, 'qr empty tied pattern');
+ ok("a=" =~ /\Q@array\E/, 'empty array pattern with \Q');
+ ok("a=" =~ qr/\Q@array\E/, 'qr empty array pattern with \Q');
+ ok("a=" =~ /\Q@global\E/, 'empty global array pattern with \Q');
+ ok("a=" =~ qr/\Q@global\E/, 'qr empty global array pattern with \Q');
+ ok("a=" =~ /\Q@tied\E/, 'empty tied pattern with \Q');
+ ok("a=" =~ qr/\Q@tied\E/, 'qr empty tied pattern with \Q');
+ ok("a=" =~ //, 'completely empty pattern');
+ ok("a=" =~ qr//, 'qr completely empty pattern');
+ }
+
+ {
+ { package o; use overload '""'=>sub { "abc" } }
+ my $x = bless [],"o";
+ my $y = \$x;
+ (my $y_addr = "$y") =~ y/()//d; # REF(0x7fcb9c02) -> REF0x7fcb9c02
+ # $y_addr =~ $y should be true, as should $y_addr =~ /(??{$y})/
+ "abc$y_addr" =~ /(??{$x})(??{$y})/;
+ is "$&", "abc$y_addr",
+ '(??{$x}) does not leak cached qr to (??{\$x}) (match)';
+ is scalar "abcabc" =~ /(??{$x})(??{$y})/, "",
+ '(??{$x}) does not leak cached qr to (??{\$x}) (no match)';
+ }
+
+ {
+ sub ReEvalTieTest::TIESCALAR {bless[], "ReEvalTieTest"}
+ sub ReEvalTieTest::STORE{}
+ sub ReEvalTieTest::FETCH { "$1" }
+ tie my $t, "ReEvalTieTest";
+ $t = bless [], "o";
+ "aab" =~ /(a)((??{"b" =~ m|(.)|; $t}))/;
+ is "[$1 $2]", "[a b]",
+ '(??{$tied_former_overload}) sees the right $1 in FETCH';
+ }
+
+ {
+ my @matchsticks;
+ my $ref = bless \my $o, "o";
+ my $foo = sub { push @matchsticks, scalar "abc" =~ /(??{$ref})/ };
+ &$foo;
+ bless \$o;
+ () = "$ref"; # flush AMAGIC flag on main
+ &$foo;
+ is "@matchsticks", "1 ", 'qr magic is not cached on refs';
+ }
+
+ {
+ my ($foo, $bar) = ("foo"x1000, "bar"x1000);
+ "$foo$bar" =~ /(??{".*"})/;
+ is "$&", "foo"x1000 . "bar"x1000,
+ 'padtmp swiping does not affect "$a$b" =~ /(??{})/'
+ }
+
} # End of sub run_tests
1;
https://perl5.git.perl.org / perl5.git / blobdiff