postpone perl_parse() exit(0) bugfix

[perl5.git] / t / op / blocks.t

diff --git a/t/op/blocks.t b/t/op/blocks.t
index 476d9ea..a4f9633 100644 (file)
--- a/t/op/blocks.t
+++ b/t/op/blocks.t
@@ -1,25 +1,25 @@
 #!./perl
 
 BEGIN {
-    chdir 't';
-    @INC = '../lib';
+    chdir 't' if -d 't';
     require './test.pl';
+    set_up_inc('../lib');
 }
 
-plan tests => 3;
+plan tests => 22;
 
 my @expect = qw(
 b1
 b2
 b3
 b4
-b6
-u5
+b6-c
 b7
 u6
+u5-c
 u1
 c3
-c2
+c2-c
 c1
 i1
 i2
@@ -27,6 +27,8 @@ b5
 u2
 u3
 u4
+b6-r
+u5-r
 e2
 e1
                );
@@ -45,9 +47,18 @@ UNITCHECK {print ":u1"}
 eval 'BEGIN {print ":b5"}';
 eval 'UNITCHECK {print ":u2"}';
 eval 'UNITCHECK {print ":u3"; UNITCHECK {print ":u4"}}';
-"a" =~ /(?{UNITCHECK {print ":u5"};
-          CHECK {print ":c2"};
-          BEGIN {print ":b6"}})/x;
+"a" =~ /(?{UNITCHECK {print ":u5-c"};
+          CHECK {print ":c2-c"};
+          BEGIN {print ":b6-c"}})/x;
+{
+    use re 'eval';
+    my $runtime = q{
+    (?{UNITCHECK {print ":u5-r"};
+              CHECK {print ":c2-r"};
+              BEGIN {print ":b6-r"}})/
+    };
+    "a" =~ /$runtime/x;
+}
 eval {BEGIN {print ":b7"}};
 eval {UNITCHECK {print ":u6"}};
 eval {INIT {print ":i2"}};
@@ -105,3 +116,57 @@ sub CHECK {print ":check"}
 sub INIT {print ":init"}
 sub END {print ":end"}
 SCRIPT3
+
+fresh_perl_is(<<'SCRIPT70614', "still here",{switches => [''], stdin => '', stderr => 1 },'eval-UNITCHECK-eval (bug 70614)');
+eval "UNITCHECK { eval 0 }"; print "still here";
+SCRIPT70614
+
+# [perl #78634] Make sure block names can be used as constants.
+use constant INIT => 5;
+::is INIT, 5, 'constant named after a special block';
+
+# [perl #108794] context
+fresh_perl_is(<<'SCRIPT3', <<expEct,{stderr => 1 },'context');
+sub context {
+    print qw[void scalar list][wantarray + defined wantarray], "\n"
+}
+BEGIN     {context}
+UNITCHECK {context}
+CHECK     {context}
+INIT      {context}
+END       {context}
+SCRIPT3
+void
+void
+void
+void
+void
+expEct
+
+fresh_perl_is('END { print "ok\n" } INIT { bless {} and exit }', "ok\n",
+              {}, 'null PL_curcop in newGP');
+
+# [perl #2754] exit(0) didn't exit from inside a UNITCHECK or CHECK block
+my $testblocks = join(" ", "BEGIN { \$| = 1; }", (map { "@{[uc($_)]} { print \"$_\\n\"; }" } qw(begin unitcheck check init end)), "print \"main\\n\";");
+fresh_perl_is($testblocks, "begin\nunitcheck\ncheck\ninit\nmain\nend", {}, 'blocks execute in right order');
+fresh_perl_is("$testblocks BEGIN { exit 0; }", "begin\nunitcheck\ncheck\ninit\nend", {}, "BEGIN{exit 0} doesn't exit yet");
+fresh_perl_is("$testblocks BEGIN { exit 1; }", "begin\nunitcheck\ncheck\nend", {}, "BEGIN{exit 1} should exit");
+fresh_perl_like("$testblocks BEGIN { die; }", qr/\Abegin\nDied[^\n]*\.\nBEGIN failed[^\n]*\.\nunitcheck\ncheck\nend\z/, {}, "BEGIN{die} should exit");
+fresh_perl_is("$testblocks UNITCHECK { exit 0; }", "begin\nunitcheck\ncheck\ninit\nmain\nend", {}, "UNITCHECK{exit 0} doesn't exit yet");
+fresh_perl_is("$testblocks UNITCHECK { exit 1; }", "begin\nunitcheck\ncheck\nend", {}, "UNITCHECK{exit 1} should exit");
+fresh_perl_like("$testblocks UNITCHECK { die; }", qr/\Abegin\nDied[^\n]*\.\nUNITCHECK failed[^\n]*\.\nunitcheck\ncheck\nend\z/, {}, "UNITCHECK{die} should exit");
+fresh_perl_is("$testblocks CHECK { exit 0; }", "begin\nunitcheck\ncheck\ninit\nmain\nend", {}, "CHECK{exit 0} doesn't exit yet");
+fresh_perl_is("$testblocks CHECK { exit 1; }", "begin\nunitcheck\ncheck\nend", {}, "CHECK{exit 1} should exit");
+fresh_perl_like("$testblocks CHECK { die; }", qr/\Abegin\nunitcheck\nDied[^\n]*\.\nCHECK failed[^\n]*\.\ncheck\nend\z/, {}, "CHECK{die} should exit");
+
+fresh_perl_is("$testblocks INIT { exit 0; }", "begin\nunitcheck\ncheck\ninit\nend", {}, "INIT{exit 0} should exit");
+fresh_perl_is("$testblocks INIT { exit 1; }", "begin\nunitcheck\ncheck\ninit\nend", {}, "INIT{exit 1} should exit");
+fresh_perl_like("$testblocks INIT { die; }", qr/\Abegin\nunitcheck\ncheck\ninit\nDied[^\n]*\.\nINIT failed[^\n]*\.\nend\z/, {}, "INIT{die} should exit");
+
+TODO: {
+    local $TODO = 'RT #2917: INIT{} in eval is wrongly considered too late';
+    fresh_perl_is('eval "INIT { print qq(in init); };";', 'in init', {}, 'RT #2917: No constraint on how late INIT blocks can run');
+}
+
+fresh_perl_is('eval "BEGIN {goto end}"; end:', '', {}, 'RT #113934: goto out of BEGIN causes assertion failure');
+