1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
|
#!perl
# Test scoping issues with embedded code in regexps.
BEGIN {
chdir 't';
@INC = qw(lib ../lib);
require './test.pl';
skip_all_if_miniperl("no dynamic loading on miniperl, no re");
}
plan 17;
# Functions for turning to-do-ness on and off (as there are so many
# to-do tests)
sub on { $::TODO = "(?{}) implementation is screwy" }
sub off { undef $::TODO }
on;
fresh_perl_is <<'CODE', '781745', {}, '(?{}) has its own lexical scope';
my $x = 7; my $a = 4; my $b = 5;
print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })a/;
print $x,$a,$b;
CODE
fresh_perl_is <<'CODE',
for my $x("a".."c") {
$y = 1;
print scalar
"abcabc" =~
/
(
a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
){2}
/x;
print "$x ";
}
CODE
'1a82a93a104a85a96a101a 1b82b93b104b85b96b101b 1c82c93c104c85c96c101c ',
{},
'multiple (?{})s in loop with lexicals';
fresh_perl_is <<'CODE', '781745', {}, 'run-time re-eval has its own scope';
use re qw(eval);
my $x = 7; my $a = 4; my $b = 5;
my $rest = 'a';
print "a" =~ /(?{ print $x; my $x = 8; print $x; my $y })$rest/;
print $x,$a,$b;
CODE
fresh_perl_is <<'CODE', '178279371047857967101745', {},
use re "eval";
my $x = 7; $y = 1;
my $a = 4; my $b = 5;
print scalar
"abcabc"
=~ ${\'(?x)
(
a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
){2}
'};
print $x,$a,$b
CODE
'multiple (?{})s in "foo" =~ $string';
fresh_perl_is <<'CODE', '178279371047857967101745', {},
use re "eval";
my $x = 7; $y = 1;
my $a = 4; my $b = 5;
print scalar
"abcabc" =~
/${\'
(
a (?{ print $y; local $y = $y+1; print $x; my $x = 8; print $x })
b (?{ print $y; local $y = $y+1; print $x; my $x = 9; print $x })
c (?{ print $y; local $y = $y+1; print $x; my $x = 10; print $x })
){2}
'}/x;
print $x,$a,$b
CODE
'multiple (?{})s in "foo" =~ /$string/x';
fresh_perl_is <<'CODE', '123123', {},
for my $x(1..3) {
push @regexps = qr/(?{ print $x })a/;
}
"a" =~ $_ for @regexps;
"ba" =~ /b$_/ for @regexps;
CODE
'qr/(?{})/ is a closure';
off;
"a" =~ do { package foo; qr/(?{ $::pack = __PACKAGE__ })a/ };
is $pack, 'foo', 'qr// inherits package';
"a" =~ do { use re "/x"; qr/(?{ $::re = qr-- })a/ };
is $re, '(?^x:)', 'qr// inherits pragmata';
on;
"ba" =~ /b${\do { package baz; qr|(?{ $::pack = __PACKAGE__ })a| }}/;
is $pack, 'baz', '/text$qr/ inherits package';
"ba" =~ m+b${\do { use re "/i"; qr|(?{ $::re = qr-- })a| }}+;
is $re, '(?^i:)', '/text$qr/ inherits pragmata';
off;
{
use re 'eval';
package bar;
"ba" =~ /${\'(?{ $::pack = __PACKAGE__ })a'}/;
}
is $pack, 'bar', '/$text/ containing (?{}) inherits package';
{
use re 'eval', "/m";
"ba" =~ /${\'(?{ $::re = qr -- })a'}/;
}
is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata';
on;
fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{die})';
eval { my $a=4; my $b=5; "a" =~ /(?{die})a/ }; print $a,$b"
CODE
SKIP: {
# The remaining TODO tests crash, which will display an error dialog
# on Windows that has to be manually dismissed. We don't want this
# to happen for release builds: 5.14.x, 5.16.x etc.
# On UNIX, they produce ugly 'Aborted' shell output mixed in with the
# test harness output, so skip on all platforms.
skip "Don't run crashing TODO test on release build", 3
if $::TODO && (int($]*1000) & 1) == 0;
fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{last})';
{ my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
CODE
fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{next})';
{ my $a=4; my $b=5; "a" =~ /(?{last})a/ }; print $a,$b
CODE
fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{return})';
print sub { my $a=4; my $b=5; "a" =~ /(?{return $a.$b})a/ }->();
CODE
}
fresh_perl_is <<'CODE', '45', { stderr => 1 }, '(?{goto})';
my $a=4; my $b=5; "a" =~ /(?{goto _})a/; die; _: print $a,$b
CODE
|
