Update releaser managers
[perl.git] / t / op / blocks.t
1 #!./perl
2
3 BEGIN {
4     chdir 't' if -d 't';
5     require './test.pl';
6     set_up_inc('../lib');
7 }
8
9 plan tests => 22;
10
11 my @expect = qw(
12 b1
13 b2
14 b3
15 b4
16 b6-c
17 b7
18 u6
19 u5-c
20 u1
21 c3
22 c2-c
23 c1
24 i1
25 i2
26 b5
27 u2
28 u3
29 u4
30 b6-r
31 u5-r
32 e2
33 e1
34                 );
35 my $expect = ":" . join(":", @expect);
36
37 fresh_perl_is(<<'SCRIPT', $expect,{switches => [''], stdin => '', stderr => 1 },'Order of execution of special blocks');
38 BEGIN {print ":b1"}
39 END {print ":e1"}
40 BEGIN {print ":b2"}
41 {
42     BEGIN {BEGIN {print ":b3"}; print ":b4"}
43 }
44 CHECK {print ":c1"}
45 INIT {print ":i1"}
46 UNITCHECK {print ":u1"}
47 eval 'BEGIN {print ":b5"}';
48 eval 'UNITCHECK {print ":u2"}';
49 eval '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 }
62 eval {BEGIN {print ":b7"}};
63 eval {UNITCHECK {print ":u6"}};
64 eval {INIT {print ":i2"}};
65 eval {CHECK {print ":c3"}};
66 END {print ":e2"}
67 SCRIPT
68
69 @expect =(
70 # BEGIN
71 qw( main bar myfoo foo ),
72 # UNITCHECK
73 qw( foo myfoo bar main ),
74 # CHECK
75 qw( foo myfoo bar main ),
76 # INIT
77 qw( main bar myfoo foo ),
78 # END
79 qw(foo myfoo bar main  ));
80
81 $expect = ":" . join(":", @expect);
82 fresh_perl_is(<<'SCRIPT2', $expect,{switches => [''], stdin => '', stderr => 1 },'blocks interact with packages/scopes');
83 BEGIN {$f = 'main'; print ":$f"}
84 UNITCHECK {print ":$f"}
85 CHECK {print ":$f"}
86 INIT {print ":$f"}
87 END {print ":$f"}
88 package bar;
89 BEGIN {$f = 'bar';print ":$f"}
90 UNITCHECK {print ":$f"}
91 CHECK {print ":$f"}
92 INIT {print ":$f"}
93 END {print ":$f"}
94 package 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 }
103 BEGIN {$f = "foo";print ":$f"}
104 UNITCHECK {print ":$f"}
105 CHECK {print ":$f"}
106 INIT {print ":$f"}
107 END {print ":$f"}
108 SCRIPT2
109
110 @expect = qw(begin unitcheck check init end);
111 $expect = ":" . join(":", @expect);
112 fresh_perl_is(<<'SCRIPT3', $expect,{switches => [''], stdin => '', stderr => 1 },'can name blocks as sub FOO');
113 sub BEGIN {print ":begin"}
114 sub UNITCHECK {print ":unitcheck"}
115 sub CHECK {print ":check"}
116 sub INIT {print ":init"}
117 sub END {print ":end"}
118 SCRIPT3
119
120 fresh_perl_is(<<'SCRIPT70614', "still here",{switches => [''], stdin => '', stderr => 1 },'eval-UNITCHECK-eval (bug 70614)');
121 eval "UNITCHECK { eval 0 }"; print "still here";
122 SCRIPT70614
123
124 # [perl #78634] Make sure block names can be used as constants.
125 use constant INIT => 5;
126 ::is INIT, 5, 'constant named after a special block';
127
128 # [perl #108794] context
129 fresh_perl_is(<<'SCRIPT3', <<expEct,{stderr => 1 },'context');
130 sub context {
131     print qw[void scalar list][wantarray + defined wantarray], "\n"
132 }
133 BEGIN     {context}
134 UNITCHECK {context}
135 CHECK     {context}
136 INIT      {context}
137 END       {context}
138 SCRIPT3
139 void
140 void
141 void
142 void
143 void
144 expEct
145
146 fresh_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
151 my $testblocks =
152     join(" ",
153         "BEGIN { \$| = 1; }",
154         (map { "@{[uc($_)]} { print \"$_\\n\"; }" }
155             qw(begin unitcheck check init end)),
156         "print \"main\\n\";"
157     );
158
159 fresh_perl_is(
160     $testblocks,
161     "begin\nunitcheck\ncheck\ninit\nmain\nend",
162     {},
163     'blocks execute in right order'
164 );
165
166 SKIP: {
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
191 SKIP: {
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
240 fresh_perl_is(
241     "$testblocks INIT { exit 0; }",
242     "begin\nunitcheck\ncheck\ninit\nend",
243     {},
244     "INIT{exit 0} should exit"
245 );
246
247 fresh_perl_is(
248     "$testblocks INIT { exit 1; }",
249     "begin\nunitcheck\ncheck\ninit\nend",
250     {},
251     "INIT{exit 1} should exit"
252 );
253
254 fresh_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
261 TODO: {
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
266 fresh_perl_is('eval "BEGIN {goto end}"; end:', '', {}, 'RT #113934: goto out of BEGIN causes assertion failure');
267