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 => 11;
  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 fresh_perl_is('BEGIN{exit 0}; print "still here"', '', {}, 'RT #2754: BEGIN{exit 0} should exit');
 150 TODO: {
 151     local $TODO = 'RT #2754: CHECK{exit 0} is broken';
 152     fresh_perl_is('CHECK{exit 0}; print "still here"', '', {}, 'RT #2754: CHECK{exit 0} should exit');
 153 }
 154
 155 TODO: {
 156     local $TODO = 'RT #2917: INIT{} in eval is wrongly considered too late';
 157     fresh_perl_is('eval "INIT { print qq(in init); };";', 'in init', {}, 'RT #2917: No constraint on how late INIT blocks can run');
 158 }
 159
 160 fresh_perl_is('eval "BEGIN {goto end}"; end:', '', {}, 'RT #113934: goto out of BEGIN causes assertion failure');
 161