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   BEGIN {
 144    if ("$]" >= 5.017_011) {
 145     require warnings;
 146     warnings->unimport('experimental::smartmatch');
 147    }
 148   }
 149   use feature 'switch';
 150   local $y;
 151   {
 152    local $x = 1;
 153    given (1) {
 154     local $x = 2;
 155     when (1) {
 156      local $x = 3;
 157      reap \&check => UP;
 158      is $x, 3,     'given/when - reap at given [not yet - x]';
 159      is $y, undef, 'given/when - reap at given [not yet - y]';
 160     }
 161     fail 'not reached';
 162    }
 163    is $x, 1, 'given/when - reap at given [ok - x]';
 164    is $y, 1, 'given/when - reap at given [ok - y]';
 165   }
 166  GIVEN_TEST_1
 167  fail $@ if $@;
 168
 169  eval <<' GIVEN_TEST_2';
 170   BEGIN {
 171    if ("$]" >= 5.017_011) {
 172     require warnings;
 173     warnings->unimport('experimental::smartmatch');
 174    }
 175   }
 176   use feature 'switch';
 177   local $y;
 178   {
 179    local $x = 1;
 180    given (1) {
 181     local $x = 2;
 182     when (1) {
 183      local $x = 3;
 184      reap \&check => UP;
 185      is $x, 3,     'given/when/continue - reap at given [not yet 1 - x]';
 186      is $y, undef, 'given/when/continue - reap at given [not yet 1 - y]';
 187      continue;
 188     }
 189     is $x, 2,     'given/when/continue - reap at given [not yet 2 - x]';
 190     is $y, undef, 'given/when/continue - reap at given [not yet 2 - y]';
 191    }
 192    is $x, 1, 'given/when/continue - reap at given [ok - x]';
 193    is $y, 1, 'given/when/continue - reap at given [ok - y]';
 194   }
 195  GIVEN_TEST_2
 196  fail $@ if $@;
 197
 198  eval <<' GIVEN_TEST_3';
 199   BEGIN {
 200    if ("$]" >= 5.017_011) {
 201     require warnings;
 202     warnings->unimport('experimental::smartmatch');
 203    }
 204   }
 205   use feature 'switch';
 206   local $y;
 207   {
 208    local $x = 1;
 209    given (1) {
 210     local $x = 2;
 211     default {
 212      local $x = 3;
 213      reap \&check => UP;
 214      is $x, 3,     'given/default - reap at given [not yet - x]';
 215      is $y, undef, 'given/default - reap at given [not yet - y]';
 216     }
 217     fail 'not reached';
 218    }
 219    is $x, 1, 'given/default - reap at given [ok - x]';
 220    is $y, 1, 'given/default - reap at given [ok - y]';
 221   }
 222  GIVEN_TEST_3
 223  fail $@ if $@;
 224
 225  eval <<' GIVEN_TEST_4';
 226   BEGIN {
 227    if ("$]" >= 5.017_011) {
 228     require warnings;
 229     warnings->unimport('experimental::smartmatch');
 230    }
 231   }
 232   use feature 'switch';
 233   local $y;
 234   {
 235    local $x = 1;
 236    given (1) {
 237     local $x = 2;
 238     default {
 239      local $x = 3;
 240      reap \&check => UP;
 241      is $x, 3,     'given/default/continue - reap at given [not yet 1 - x]';
 242      is $y, undef, 'given/default/continue - reap at given [not yet 1 - y]';
 243      continue;
 244     }
 245     is $x, 2,     'given/default/continue - reap at given [not yet 2 - x]';
 246     is $y, undef, 'given/default/continue - reap at given [not yet 2 - y]';
 247    }
 248    is $x, 1, 'given/default/continue - reap at given [ok - x]';
 249    is $y, 1, 'given/default/continue - reap at given [ok - y]';
 250   }
 251  GIVEN_TEST_4
 252  fail $@ if $@;
 253
 254  eval <<' GIVEN_TEST_5';
 255   BEGIN {
 256    if ("$]" >= 5.017_011) {
 257     require warnings;
 258     warnings->unimport('experimental::smartmatch');
 259    }
 260   }
 261   use feature 'switch';
 262   local $y;
 263   {
 264    local $x = 1;
 265    given (1) {
 266     local $x = 2;
 267     default {
 268      local $x = 3;
 269      given (2) {
 270       local $x = 4;
 271       when (2) {
 272        local $x = 5;
 273        reap \&check => UP UP;
 274        is $x, 5,     'given/default/given/when - reap at default [not yet 1 - x]';
 275        is $y, undef, 'given/default/given/when - reap at default [not yet 1 - y]';
 276        continue;
 277       }
 278       is $x, 4,     'given/default/given/when - reap at default [not yet 2 - x]';
 279       is $y, undef, 'given/default/given/when - reap at default [not yet 2 - y]';
 280      }
 281      is $x, 3,     'given/default/given/when - reap at default [not yet 3 - x]';
 282      is $y, undef, 'given/default/given/when - reap at default [not yet 3 - y]';
 283      continue;
 284     }
 285     is $x, 2, 'given/default/given/when - reap at default [ok 1 - x]';
 286     is $y, 1, 'given/default/given/when - reap at default [ok 1 - y]';
 287    }
 288    is $x, 1, 'given/default/given/when - reap at default [ok 2 - x]';
 289    is $y, 1, 'given/default/given/when - reap at default [ok 2 - y]';
 290   }
 291  GIVEN_TEST_5
 292  fail $@ if $@;
 293 }
 294
 295 $y = undef;
 296 {
 297  local $x = 1;
 298  eval {
 299   local $x = 2;
 300   eval {
 301    local $x = 3;
 302    reap { ++$y; die "reaped\n" } => HERE;
 303    is $x, 3,     'die in reap at eval [not yet - x]';
 304    is $y, undef, 'die in reap at eval [not yet - y]';
 305   }; # should trigger here, but the die isn't catched by this eval
 306   die "failed\n";
 307  };
 308  is $@, "reaped\n", 'die in reap at eval [ok - $@]';
 309  is $x, 1, 'die in reap at eval [ok - x]';
 310  is $y, 1, 'die in reap at eval [ok - y]';
 311 }
 312
 313 $y = undef;
 314 {
 315  local $x = 1;
 316  eval {
 317   local $x = 2;
 318   {
 319    local $x = 3;
 320    reap { ++$y; die "reaped\n" } => HERE;
 321    is $x, 3,     'die in reap inside eval [not yet - x]';
 322    is $y, undef, 'die in reap inside eval [not yet - y]';
 323   } # should trigger here
 324   die "failed\n";
 325  };
 326  is $@, "reaped\n", 'die in reap inside eval [ok - $@]';
 327  is $x, 1, 'die in reap inside eval [ok - x]';
 328  is $y, 1, 'die in reap inside eval [ok - y]';
 329 }
 330
 331 sub hijacked {
 332  my ($cb, $desc) = @_;
 333  local $x = 2;
 334  sub {
 335   local $x = 3;
 336   &reap($cb => UP);
 337   is $x, 3,     "$desc [not yet 1 - x]";
 338   is $y, undef, "$desc [not yet 1 - y]";
 339  }->();
 340  is $x, 2,     "$desc [not yet 2 - x]";
 341  is $y, undef, "$desc [not yet 2 - y]";
 342  11, 12;
 343 }
 344
 345 for ([ sub { ++$y; 15, 16, 17, 18 },        'implicit ' ],
 346      [ sub { ++$y; return 15, 16, 17, 18 }, ''          ]) {
 347  my ($cb, $imp) = @$_;
 348  $imp = "RT #44204 - ${imp}return from reap";
 349  my $desc;
 350  $y = undef;
 351  {
 352   $desc = "$imp in list context";
 353   local $x = 1;
 354   my @l = hijacked($cb, $desc);
 355   is $x,         1,          "$desc [ok - x]";
 356   is $y,         1,          "$desc [ok - y]";
 357   is_deeply \@l, [ 11, 12 ], "$desc [ok - l]";
 358  }
 359  $y = undef;
 360  {
 361   $desc = "$imp in list context";
 362   local $x = 1;
 363   my $s = hijacked($cb, $desc);
 364   is $x, 1,  "$desc [ok - x]";
 365   is $y, 1,  "$desc [ok - y]";
 366   is $s, 12, "$desc [ok - s]";
 367  }
 368 }