BEGIN {
chdir 't' if -d 't';
- @INC = ('../lib','.');
require './test.pl';
- skip_all_if_miniperl("no dynamic loading on miniperl, no re");
+ @INC = () unless is_miniperl();
+ unshift @INC, '../lib';
}
-plan tests => 444; # Update this when adding/deleting tests.
+plan tests => 527; # Update this when adding/deleting tests.
run_tests() unless caller;
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');
}
}
}
# 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)
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($@,
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
https://perl5.git.perl.org / perl5.git / blobdiff