t/13-reap-ctl.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 41 + 30 + 4 * 7;
   7
   8 use Scope::Upper qw<reap UP HERE>;
   9
  10 our ($x, $y);
  11
  12 sub check { ++$y }
  13
  14 {
  15  local $x = 1;
  16  {
  17   local $x = 2;
  18   {
  19    reap \&check => UP;
  20   }
  21   is $x, 2,     'goto 1 [not yet - x]';
  22   is $y, undef, 'goto 1 [not yet - y]';
  23   {
  24    local $x = 3;
  25    goto OVER1;
  26   }
  27  }
  28  $y = 0;
  29 OVER1:
  30  is $x, 1, 'goto 1 [ok - x]';
  31  is $y, 1, 'goto 1 [ok - y]';
  32 }
  33
  34 $y = undef;
  35 {
  36  local $x = 1;
  37  {
  38   local $x = 2;
  39   {
  40    local $x = 3;
  41    {
  42     reap \&check => UP UP;
  43    }
  44    is $x, 3,     'goto 2 [not yet - x]';
  45    is $y, undef, 'goto 2 [not yet - y]';
  46    {
  47     local $x = 4;
  48     goto OVER2;
  49    }
  50   }
  51  }
  52  $y = 0;
  53 OVER2:
  54  is $x, 1, 'goto 2 [ok - x]';
  55  is $y, 1, 'goto 2 [ok - y]';
  56 }
  57
  58 $y = undef;
  59 {
  60  local $x = 1;
  61  {
  62   eval {
  63    local $x = 2;
  64    {
  65     {
  66      local $x = 3;
  67      reap \&check => UP UP UP;
  68      is $x, 3,     'die - reap outside eval [not yet 1 - x]';
  69      is $y, undef, 'die - reap outside eval [not yet 1 - y]';
  70     }
  71     is $x, 2,     'die - reap outside eval [not yet 2 - x]';
  72     is $y, undef, 'die - reap outside eval [not yet 2 - y]';
  73     die;
  74    }
  75   };
  76   is $x, 1,     'die - reap outside eval [not yet 3 - x]';
  77   is $y, undef, 'die - reap outside eval [not yet 3 - y]';
  78  } # should trigger here
  79  is $x, 1, 'die - reap outside eval [ok - x]';
  80  is $y, 1, 'die - reap outside eval [ok - y]';
  81 }
  82
  83 $y = undef;
  84 {
  85  local $x = 1;
  86  eval {
  87   local $x = 2;
  88   {
  89    {
  90     local $x = 3;
  91     reap \&check => UP UP;
  92     is $x, 3,     'die - reap at eval [not yet 1 - x]';
  93     is $y, undef, 'die - reap at eval [not yet 1 - y]';
  94    }
  95    is $x, 2,     'die - reap at eval [not yet 2 - x]';
  96    is $y, undef, 'die - reap at eval [not yet 2 - y]';
  97    die;
  98   }
  99  }; # should trigger here
 100  is $x, 1, 'die - reap at eval [ok - x]';
 101  is $y, 1, 'die - reap at eval [ok - y]';
 102 }
 103
 104 $y = undef;
 105 {
 106  local $x = 1;
 107  eval {
 108   local $x = 2;
 109   {
 110    {
 111     local $x = 3;
 112     reap \&check => UP;
 113     is $x, 3,     'die - reap inside eval [not yet 1 - x]';
 114     is $y, undef, 'die - reap inside eval [not yet 1 - y]';
 115    }
 116    is $x, 2,     'die - reap inside eval [not yet 2 - x]';
 117    is $y, undef, 'die - reap inside eval [not yet 2 - y]';
 118    die;
 119   } # should trigger here
 120  };
 121  is $x, 1, 'die - reap inside eval [ok - x]';
 122  is $y, 1, 'die - reap inside eval [ok - y]';
 123 }
 124
 125 {
 126  my $z      = 0;
 127  my $reaped = 0;
 128  eval {
 129   reap { $reaped = 1 };
 130   is $reaped, 0, 'died of natural death - not reaped yet';
 131   my $res = 1 / $z;
 132  };
 133  my $err = $@;
 134  is   $reaped, 1,                    'died of natural death - reaped';
 135  like $err,    qr/division by zero/, 'died of natural death - divided by zero';
 136 }
 137
 138 SKIP:
 139 {
 140  skip 'Perl 5.10 required to test given/when' => 30 if "$]" < 5.010;
 141
 142  eval <<' GIVEN_TEST_1';
 143   use feature 'switch';
 144   local $y;
 145   {
 146    local $x = 1;
 147    given (1) {
 148     local $x = 2;
 149     when (1) {
 150      local $x = 3;
 151      reap \&check => UP;
 152      is $x, 3,     'given/when - reap at given [not yet - x]';
 153      is $y, undef, 'given/when - reap at given [not yet - y]';
 154     }
 155     fail 'not reached';
 156    }
 157    is $x, 1, 'given/when - reap at given [ok - x]';
 158    is $y, 1, 'given/when - reap at given [ok - y]';
 159   }
 160  GIVEN_TEST_1
 161  fail $@ if $@;
 162
 163  eval <<' GIVEN_TEST_2';
 164   use feature 'switch';
 165   local $y;
 166   {
 167    local $x = 1;
 168    given (1) {
 169     local $x = 2;
 170     when (1) {
 171      local $x = 3;
 172      reap \&check => UP;
 173      is $x, 3,     'given/when/continue - reap at given [not yet 1 - x]';
 174      is $y, undef, 'given/when/continue - reap at given [not yet 1 - y]';
 175      continue;
 176     }
 177     is $x, 2,     'given/when/continue - reap at given [not yet 2 - x]';
 178     is $y, undef, 'given/when/continue - reap at given [not yet 2 - y]';
 179    }
 180    is $x, 1, 'given/when/continue - reap at given [ok - x]';
 181    is $y, 1, 'given/when/continue - reap at given [ok - y]';
 182   }
 183  GIVEN_TEST_2
 184  fail $@ if $@;
 185
 186  eval <<' GIVEN_TEST_3';
 187   use feature 'switch';
 188   local $y;
 189   {
 190    local $x = 1;
 191    given (1) {
 192     local $x = 2;
 193     default {
 194      local $x = 3;
 195      reap \&check => UP;
 196      is $x, 3,     'given/default - reap at given [not yet - x]';
 197      is $y, undef, 'given/default - reap at given [not yet - y]';
 198     }
 199     fail 'not reached';
 200    }
 201    is $x, 1, 'given/default - reap at given [ok - x]';
 202    is $y, 1, 'given/default - reap at given [ok - y]';
 203   }
 204  GIVEN_TEST_3
 205  fail $@ if $@;
 206
 207  eval <<' GIVEN_TEST_4';
 208   use feature 'switch';
 209   local $y;
 210   {
 211    local $x = 1;
 212    given (1) {
 213     local $x = 2;
 214     default {
 215      local $x = 3;
 216      reap \&check => UP;
 217      is $x, 3,     'given/default/continue - reap at given [not yet 1 - x]';
 218      is $y, undef, 'given/default/continue - reap at given [not yet 1 - y]';
 219      continue;
 220     }
 221     is $x, 2,     'given/default/continue - reap at given [not yet 2 - x]';
 222     is $y, undef, 'given/default/continue - reap at given [not yet 2 - y]';
 223    }
 224    is $x, 1, 'given/default/continue - reap at given [ok - x]';
 225    is $y, 1, 'given/default/continue - reap at given [ok - y]';
 226   }
 227  GIVEN_TEST_4
 228  fail $@ if $@;
 229
 230  eval <<' GIVEN_TEST_5';
 231   use feature 'switch';
 232   local $y;
 233   {
 234    local $x = 1;
 235    given (1) {
 236     local $x = 2;
 237     default {
 238      local $x = 3;
 239      given (2) {
 240       local $x = 4;
 241       when (2) {
 242        local $x = 5;
 243        reap \&check => UP UP;
 244        is $x, 5,     'given/default/given/when - reap at default [not yet 1 - x]';
 245        is $y, undef, 'given/default/given/when - reap at default [not yet 1 - y]';
 246        continue;
 247       }
 248       is $x, 4,     'given/default/given/when - reap at default [not yet 2 - x]';
 249       is $y, undef, 'given/default/given/when - reap at default [not yet 2 - y]';
 250      }
 251      is $x, 3,     'given/default/given/when - reap at default [not yet 3 - x]';
 252      is $y, undef, 'given/default/given/when - reap at default [not yet 3 - y]';
 253      continue;
 254     }
 255     is $x, 2, 'given/default/given/when - reap at default [ok 1 - x]';
 256     is $y, 1, 'given/default/given/when - reap at default [ok 1 - y]';
 257    }
 258    is $x, 1, 'given/default/given/when - reap at default [ok 2 - x]';
 259    is $y, 1, 'given/default/given/when - reap at default [ok 2 - y]';
 260   }
 261  GIVEN_TEST_5
 262  fail $@ if $@;
 263 }
 264
 265 $y = undef;
 266 {
 267  local $x = 1;
 268  eval {
 269   local $x = 2;
 270   eval {
 271    local $x = 3;
 272    reap { ++$y; die "reaped\n" } => HERE;
 273    is $x, 3,     'die in reap at eval [not yet - x]';
 274    is $y, undef, 'die in reap at eval [not yet - y]';
 275   }; # should trigger here, but the die isn't catched by this eval
 276   die "failed\n";
 277  };
 278  is $@, "reaped\n", 'die in reap at eval [ok - $@]';
 279  is $x, 1, 'die in reap at eval [ok - x]';
 280  is $y, 1, 'die in reap at eval [ok - y]';
 281 }
 282
 283 $y = undef;
 284 {
 285  local $x = 1;
 286  eval {
 287   local $x = 2;
 288   {
 289    local $x = 3;
 290    reap { ++$y; die "reaped\n" } => HERE;
 291    is $x, 3,     'die in reap inside eval [not yet - x]';
 292    is $y, undef, 'die in reap inside eval [not yet - y]';
 293   } # should trigger here
 294   die "failed\n";
 295  };
 296  is $@, "reaped\n", 'die in reap inside eval [ok - $@]';
 297  is $x, 1, 'die in reap inside eval [ok - x]';
 298  is $y, 1, 'die in reap inside eval [ok - y]';
 299 }
 300
 301 sub hijacked {
 302  my ($cb, $desc) = @_;
 303  local $x = 2;
 304  sub {
 305   local $x = 3;
 306   &reap($cb => UP);
 307   is $x, 3,     "$desc [not yet 1 - x]";
 308   is $y, undef, "$desc [not yet 1 - y]";
 309  }->();
 310  is $x, 2,     "$desc [not yet 2 - x]";
 311  is $y, undef, "$desc [not yet 2 - y]";
 312  11, 12;
 313 }
 314
 315 for ([ sub { ++$y; 15, 16, 17, 18 },        'implicit ' ],
 316      [ sub { ++$y; return 15, 16, 17, 18 }, ''          ]) {
 317  my ($cb, $imp) = @$_;
 318  $imp = "RT #44204 - ${imp}return from reap";
 319  my $desc;
 320  $y = undef;
 321  {
 322   $desc = "$imp in list context";
 323   local $x = 1;
 324   my @l = hijacked($cb, $desc);
 325   is $x,         1,          "$desc [ok - x]";
 326   is $y,         1,          "$desc [ok - y]";
 327   is_deeply \@l, [ 11, 12 ], "$desc [ok - l]";
 328  }
 329  $y = undef;
 330  {
 331   $desc = "$imp in list context";
 332   local $x = 1;
 333   my $s = hijacked($cb, $desc);
 334   is $x, 1,  "$desc [ok - x]";
 335   is $y, 1,  "$desc [ok - y]";
 336   is $s, 12, "$desc [ok - s]";
 337  }
 338 }