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