1#!./perl 2 3BEGIN { 4 chdir 't' if -d 't'; 5 require './test.pl'; 6 set_up_inc('../lib'); 7} 8 9plan tests => 26; 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 150my $testblocks = 151 join(" ", 152 "BEGIN { \$| = 1; }", 153 (map { "@{[uc($_)]} { print \"$_\\n\"; }" } 154 qw(begin unitcheck check init end)), 155 "print \"main\\n\";" 156 ); 157 158fresh_perl_is( 159 $testblocks, 160 "begin\nunitcheck\ncheck\ninit\nmain\nend", 161 {}, 162 'blocks execute in right order' 163); 164 165SKIP: { 166 skip "VMS doesn't have the perl #2754 bug", 3 if $^O eq 'VMS'; 167 fresh_perl_is( 168 "$testblocks BEGIN { exit 0; }", 169 "begin\nunitcheck\ncheck\nend", 170 {}, 171 "BEGIN{exit 0} doesn't exit yet" 172 ); 173 174 fresh_perl_is( 175 "$testblocks UNITCHECK { exit 0; }", 176 "begin\nunitcheck\ncheck\nend", 177 {}, 178 "UNITCHECK{exit 0} doesn't exit yet" 179 ); 180 181 fresh_perl_is( 182 "$testblocks CHECK { exit 0; }", 183 "begin\nunitcheck\ncheck\nend", 184 {}, 185 "CHECK{exit 0} doesn't exit yet" 186 ); 187} 188 189 190SKIP: { 191 fresh_perl_is( 192 "$testblocks BEGIN { exit 1; }", 193 "begin\nunitcheck\ncheck\nend", 194 {}, 195 "BEGIN{exit 1} should exit" 196 ); 197 198 fresh_perl_like( 199 "$testblocks BEGIN { die; }", 200 qr/\Abegin\nDied[^\n]*\.\nBEGIN failed[^\n]*\.\nunitcheck\ncheck\nend\z/, 201 {}, 202 "BEGIN{die} should exit" 203 ); 204 205 fresh_perl_is( 206 "$testblocks UNITCHECK { exit 1; }", 207 "begin\nunitcheck\ncheck\nend", 208 {}, 209 "UNITCHECK{exit 1} should exit" 210 ); 211 212 fresh_perl_like( 213 "$testblocks UNITCHECK { die; }", 214 qr/\Abegin\nDied[^\n]*\.\nUNITCHECK failed[^\n]*\.\nunitcheck\ncheck\nend\z/, 215 {}, 216 "UNITCHECK{die} should exit" 217 ); 218 219 220 fresh_perl_is( 221 "$testblocks CHECK { exit 1; }", 222 "begin\nunitcheck\ncheck\nend", 223 {}, 224 "CHECK{exit 1} should exit" 225 ); 226 227 fresh_perl_like( 228 "$testblocks CHECK { die; }", 229 qr/\Abegin\nunitcheck\nDied[^\n]*\.\nCHECK failed[^\n]*\.\ncheck\nend\z/, 230 {}, 231 "CHECK{die} should exit" 232 ); 233} 234 235fresh_perl_is( 236 "$testblocks INIT { exit 0; }", 237 "begin\nunitcheck\ncheck\ninit\nend", 238 {}, 239 "INIT{exit 0} should exit" 240); 241 242fresh_perl_is( 243 "$testblocks INIT { exit 1; }", 244 "begin\nunitcheck\ncheck\ninit\nend", 245 {}, 246 "INIT{exit 1} should exit" 247); 248 249fresh_perl_like( 250 "$testblocks INIT { die; }", 251 qr/\Abegin\nunitcheck\ncheck\ninit\nDied[^\n]*\.\nINIT failed[^\n]*\.\nend\z/, 252 {}, 253 "INIT{die} should exit" 254); 255 256fresh_perl_is( 257 "BEGIN{} BEGIN(){1} print 'done'", 258 "Prototype on BEGIN block ignored at - line 1.\ndone", 259 {}, 260 "Prototypes on BEGIN blocks should warn" 261); 262 263SKIP: { 264 skip "Test requires full perl, this is miniperl", 1 265 if is_miniperl; 266 267 fresh_perl_is( 268 "use attributes; BEGIN{} sub BEGIN :blerg {1} print 'done'", 269 "Attribute on BEGIN block ignored at - line 1.\ndone", 270 {}, 271 "Attributes on BEGIN blocks should warn" 272 ); 273} 274 275fresh_perl_is( 276 'BEGIN() {10} foreach my $p (sort {lc($a) cmp lc($b)} keys %v)', 277 "Prototype on BEGIN block ignored at - line 1.\n" 278 . "syntax error at - line 1, at EOF\n" 279 . "Execution of - aborted due to compilation errors.", 280 {}, 281 "Prototype on BEGIN blocks should warn" 282); 283 284TODO: { 285 local $TODO = 'RT #2917: INIT{} in eval is wrongly considered too late'; 286 fresh_perl_is('eval "INIT { print qq(in init); };";', 'in init', {}, 'RT #2917: No constraint on how late INIT blocks can run'); 287} 288 289fresh_perl_is('eval "BEGIN {goto end}"; end:', '', {}, 'RT #113934: goto out of BEGIN causes assertion failure'); 290 291fresh_perl_is('package Module::Install::DSL; BEGIN { eval "INIT { print q(INIT fired in eval) }" }', 292 "Treating Module::Install::DSL::INIT block as BEGIN block as workaround at (eval 1) line 1.\n" 293 ."INIT fired in eval", {}, 294 'GH Issue #16300: Module::Install::DSL workaround'); 295