1#!./perl
2
3BEGIN {
4    chdir 't' if -d 't';
5    require './test.pl';
6    set_up_inc('../lib');
7}
8
9plan tests => 22;
10
11my @expect = qw(
12b1
13b2
14b3
15b4
16b6-c
17b7
18u6
19u5-c
20u1
21c3
22c2-c
23c1
24i1
25i2
26b5
27u2
28u3
29u4
30b6-r
31u5-r
32e2
33e1
34		);
35my $expect = ":" . join(":", @expect);
36
37fresh_perl_is(<<'SCRIPT', $expect,{switches => [''], stdin => '', stderr => 1 },'Order of execution of special blocks');
38BEGIN {print ":b1"}
39END {print ":e1"}
40BEGIN {print ":b2"}
41{
42    BEGIN {BEGIN {print ":b3"}; print ":b4"}
43}
44CHECK {print ":c1"}
45INIT {print ":i1"}
46UNITCHECK {print ":u1"}
47eval 'BEGIN {print ":b5"}';
48eval 'UNITCHECK {print ":u2"}';
49eval 'UNITCHECK {print ":u3"; UNITCHECK {print ":u4"}}';
50"a" =~ /(?{UNITCHECK {print ":u5-c"};
51	   CHECK {print ":c2-c"};
52	   BEGIN {print ":b6-c"}})/x;
53{
54    use re 'eval';
55    my $runtime = q{
56    (?{UNITCHECK {print ":u5-r"};
57	       CHECK {print ":c2-r"};
58	       BEGIN {print ":b6-r"}})/
59    };
60    "a" =~ /$runtime/x;
61}
62eval {BEGIN {print ":b7"}};
63eval {UNITCHECK {print ":u6"}};
64eval {INIT {print ":i2"}};
65eval {CHECK {print ":c3"}};
66END {print ":e2"}
67SCRIPT
68
69@expect =(
70# BEGIN
71qw( main bar myfoo foo ),
72# UNITCHECK
73qw( foo myfoo bar main ),
74# CHECK
75qw( foo myfoo bar main ),
76# INIT
77qw( main bar myfoo foo ),
78# END
79qw(foo myfoo bar main  ));
80
81$expect = ":" . join(":", @expect);
82fresh_perl_is(<<'SCRIPT2', $expect,{switches => [''], stdin => '', stderr => 1 },'blocks interact with packages/scopes');
83BEGIN {$f = 'main'; print ":$f"}
84UNITCHECK {print ":$f"}
85CHECK {print ":$f"}
86INIT {print ":$f"}
87END {print ":$f"}
88package bar;
89BEGIN {$f = 'bar';print ":$f"}
90UNITCHECK {print ":$f"}
91CHECK {print ":$f"}
92INIT {print ":$f"}
93END {print ":$f"}
94package foo;
95{
96    my $f;
97    BEGIN {$f = 'myfoo'; print ":$f"}
98    UNITCHECK {print ":$f"}
99    CHECK {print ":$f"}
100    INIT {print ":$f"}
101    END {print ":$f"}
102}
103BEGIN {$f = "foo";print ":$f"}
104UNITCHECK {print ":$f"}
105CHECK {print ":$f"}
106INIT {print ":$f"}
107END {print ":$f"}
108SCRIPT2
109
110@expect = qw(begin unitcheck check init end);
111$expect = ":" . join(":", @expect);
112fresh_perl_is(<<'SCRIPT3', $expect,{switches => [''], stdin => '', stderr => 1 },'can name blocks as sub FOO');
113sub BEGIN {print ":begin"}
114sub UNITCHECK {print ":unitcheck"}
115sub CHECK {print ":check"}
116sub INIT {print ":init"}
117sub END {print ":end"}
118SCRIPT3
119
120fresh_perl_is(<<'SCRIPT70614', "still here",{switches => [''], stdin => '', stderr => 1 },'eval-UNITCHECK-eval (bug 70614)');
121eval "UNITCHECK { eval 0 }"; print "still here";
122SCRIPT70614
123
124# [perl #78634] Make sure block names can be used as constants.
125use constant INIT => 5;
126::is INIT, 5, 'constant named after a special block';
127
128# [perl #108794] context
129fresh_perl_is(<<'SCRIPT3', <<expEct,{stderr => 1 },'context');
130sub context {
131    print qw[void scalar list][wantarray + defined wantarray], "\n"
132}
133BEGIN     {context}
134UNITCHECK {context}
135CHECK     {context}
136INIT      {context}
137END       {context}
138SCRIPT3
139void
140void
141void
142void
143void
144expEct
145
146fresh_perl_is('END { print "ok\n" } INIT { bless {} and exit }', "ok\n",
147	       {}, 'null PL_curcop in newGP');
148
149# [perl #2754] exit(0) didn't exit from inside a UNITCHECK or CHECK block
150
151my $testblocks =
152    join(" ",
153        "BEGIN { \$| = 1; }",
154        (map { "@{[uc($_)]} { print \"$_\\n\"; }" }
155            qw(begin unitcheck check init end)),
156        "print \"main\\n\";"
157    );
158
159fresh_perl_is(
160    $testblocks,
161    "begin\nunitcheck\ncheck\ninit\nmain\nend",
162    {},
163    'blocks execute in right order'
164);
165
166SKIP: {
167    skip "VMS doesn't have the perl #2754 bug", 3 if $^O eq 'VMS';
168    fresh_perl_is(
169        "$testblocks BEGIN { exit 0; }",
170        "begin\nunitcheck\ncheck\ninit\nend",
171        {},
172        "BEGIN{exit 0} doesn't exit yet"
173    );
174
175    fresh_perl_is(
176        "$testblocks UNITCHECK { exit 0; }",
177        "begin\nunitcheck\ncheck\ninit\nmain\nend",
178        {},
179        "UNITCHECK{exit 0} doesn't exit yet"
180    );
181
182    fresh_perl_is(
183        "$testblocks CHECK { exit 0; }",
184        "begin\nunitcheck\ncheck\ninit\nmain\nend",
185        {},
186        "CHECK{exit 0} doesn't exit yet"
187    );
188}
189
190
191SKIP: {
192    if ($^O =~ /^(MSWin32|NetWare|os2)$/) {
193        skip "non_UNIX plafforms and PERL_EXIT_DESTRUCT_END (RT #132863)", 6;
194    }
195
196    fresh_perl_is(
197        "$testblocks BEGIN { exit 1; }",
198        "begin\nunitcheck\ncheck\nend",
199        {},
200        "BEGIN{exit 1} should exit"
201    );
202
203    fresh_perl_like(
204        "$testblocks BEGIN { die; }",
205        qr/\Abegin\nDied[^\n]*\.\nBEGIN failed[^\n]*\.\nunitcheck\ncheck\nend\z/,
206        {},
207        "BEGIN{die} should exit"
208    );
209
210    fresh_perl_is(
211        "$testblocks UNITCHECK { exit 1; }",
212        "begin\nunitcheck\ncheck\nend",
213        {},
214        "UNITCHECK{exit 1} should exit"
215    );
216
217    fresh_perl_like(
218        "$testblocks UNITCHECK { die; }",
219        qr/\Abegin\nDied[^\n]*\.\nUNITCHECK failed[^\n]*\.\nunitcheck\ncheck\nend\z/,
220        {},
221        "UNITCHECK{die} should exit"
222    );
223
224
225    fresh_perl_is(
226        "$testblocks CHECK { exit 1; }",
227        "begin\nunitcheck\ncheck\nend",
228        {},
229        "CHECK{exit 1} should exit"
230    );
231
232    fresh_perl_like(
233        "$testblocks CHECK { die; }",
234        qr/\Abegin\nunitcheck\nDied[^\n]*\.\nCHECK failed[^\n]*\.\ncheck\nend\z/,
235        {},
236        "CHECK{die} should exit"
237    );
238}
239
240fresh_perl_is(
241    "$testblocks INIT { exit 0; }",
242    "begin\nunitcheck\ncheck\ninit\nend",
243    {},
244    "INIT{exit 0} should exit"
245);
246
247fresh_perl_is(
248    "$testblocks INIT { exit 1; }",
249    "begin\nunitcheck\ncheck\ninit\nend",
250    {},
251    "INIT{exit 1} should exit"
252);
253
254fresh_perl_like(
255    "$testblocks INIT { die; }",
256    qr/\Abegin\nunitcheck\ncheck\ninit\nDied[^\n]*\.\nINIT failed[^\n]*\.\nend\z/,
257    {},
258    "INIT{die} should exit"
259);
260
261TODO: {
262    local $TODO = 'RT #2917: INIT{} in eval is wrongly considered too late';
263    fresh_perl_is('eval "INIT { print qq(in init); };";', 'in init', {}, 'RT #2917: No constraint on how late INIT blocks can run');
264}
265
266fresh_perl_is('eval "BEGIN {goto end}"; end:', '', {}, 'RT #113934: goto out of BEGIN causes assertion failure');
267
268