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 => 459; # Update this when adding/deleting tests.
+plan tests => 527; # Update this when adding/deleting tests.
run_tests() unless caller;
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("@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)
# does all the right escapes
{
- 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;
}
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/ })
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;
+ use warnings 'deprecated';
use re 'eval';
ok($ss =~ /^$cc/, fmt("encode $u->[2]", $ss, $cc));
}
}
my $code1u = "(??{qw(\x{100})})";
- eval {/^$code1u$/}; norun("reparse embeded unicode norun");
+ eval {/^$code1u$/}; norun("reparse embedded unicode norun");
{
use re 'eval';
- ok("\x{100}" =~ /^$code1u$/, "reparse embeded unicode");
+ ok("\x{100}" =~ /^$code1u$/, "reparse embedded unicode");
}
}
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
}
}
+ # [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