t/13-reap-ctl.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 38 + 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 SKIP:
 126 {
 127  skip 'Perl 5.10 required to test given/when' => 30 if $] < 5.010;
 128
 129  eval <<' GIVEN_TEST_1';
 130   use feature 'switch';
 131   local $y;
 132   {
 133    local $x = 1;
 134    given (1) {
 135     local $x = 2;
 136     when (1) {
 137      local $x = 3;
 138      reap \&check => UP;
 139      is $x, 3,     'given/when - reap at given [not yet - x]';
 140      is $y, undef, 'given/when - reap at given [not yet - y]';
 141     }
 142     fail 'not reached';
 143    }
 144    is $x, 1, 'given/when - reap at given [ok - x]';
 145    is $y, 1, 'given/when - reap at given [ok - y]';
 146   }
 147  GIVEN_TEST_1
 148  fail $@ if $@;
 149
 150  eval <<' GIVEN_TEST_2';
 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/continue - reap at given [not yet 1 - x]';
 161      is $y, undef, 'given/when/continue - reap at given [not yet 1 - y]';
 162      continue;
 163     }
 164     is $x, 2,     'given/when/continue - reap at given [not yet 2 - x]';
 165     is $y, undef, 'given/when/continue - reap at given [not yet 2 - y]';
 166    }
 167    is $x, 1, 'given/when/continue - reap at given [ok - x]';
 168    is $y, 1, 'given/when/continue - reap at given [ok - y]';
 169   }
 170  GIVEN_TEST_2
 171  fail $@ if $@;
 172
 173  eval <<' GIVEN_TEST_3';
 174   use feature 'switch';
 175   local $y;
 176   {
 177    local $x = 1;
 178    given (1) {
 179     local $x = 2;
 180     default {
 181      local $x = 3;
 182      reap \&check => UP;
 183      is $x, 3,     'given/default - reap at given [not yet - x]';
 184      is $y, undef, 'given/default - reap at given [not yet - y]';
 185     }
 186     fail 'not reached';
 187    }
 188    is $x, 1, 'given/default - reap at given [ok - x]';
 189    is $y, 1, 'given/default - reap at given [ok - y]';
 190   }
 191  GIVEN_TEST_3
 192  fail $@ if $@;
 193
 194  eval <<' GIVEN_TEST_4';
 195   use feature 'switch';
 196   local $y;
 197   {
 198    local $x = 1;
 199    given (1) {
 200     local $x = 2;
 201     default {
 202      local $x = 3;
 203      reap \&check => UP;
 204      is $x, 3,     'given/default/continue - reap at given [not yet 1 - x]';
 205      is $y, undef, 'given/default/continue - reap at given [not yet 1 - y]';
 206      continue;
 207     }
 208     is $x, 2,     'given/default/continue - reap at given [not yet 2 - x]';
 209     is $y, undef, 'given/default/continue - reap at given [not yet 2 - y]';
 210    }
 211    is $x, 1, 'given/default/continue - reap at given [ok - x]';
 212    is $y, 1, 'given/default/continue - reap at given [ok - y]';
 213   }
 214  GIVEN_TEST_4
 215  fail $@ if $@;
 216
 217  eval <<' GIVEN_TEST_5';
 218   use feature 'switch';
 219   local $y;
 220   {
 221    local $x = 1;
 222    given (1) {
 223     local $x = 2;
 224     default {
 225      local $x = 3;
 226      given (2) {
 227       local $x = 4;
 228       when (2) {
 229        local $x = 5;
 230        reap \&check => UP UP;
 231        is $x, 5,     'given/default/given/when - reap at default [not yet 1 - x]';
 232        is $y, undef, 'given/default/given/when - reap at default [not yet 1 - y]';
 233        continue;
 234       }
 235       is $x, 4,     'given/default/given/when - reap at default [not yet 2 - x]';
 236       is $y, undef, 'given/default/given/when - reap at default [not yet 2 - y]';
 237      }
 238      is $x, 3,     'given/default/given/when - reap at default [not yet 3 - x]';
 239      is $y, undef, 'given/default/given/when - reap at default [not yet 3 - y]';
 240      continue;
 241     }
 242     is $x, 2, 'given/default/given/when - reap at default [ok 1 - x]';
 243     is $y, 1, 'given/default/given/when - reap at default [ok 1 - y]';
 244    }
 245    is $x, 1, 'given/default/given/when - reap at default [ok 2 - x]';
 246    is $y, 1, 'given/default/given/when - reap at default [ok 2 - y]';
 247   }
 248  GIVEN_TEST_5
 249  fail $@ if $@;
 250 }
 251
 252 $y = undef;
 253 {
 254  local $x = 1;
 255  eval {
 256   local $x = 2;
 257   eval {
 258    local $x = 3;
 259    reap { ++$y; die "reaped\n" } => HERE;
 260    is $x, 3,     'die in reap at eval [not yet - x]';
 261    is $y, undef, 'die in reap at eval [not yet - y]';
 262   }; # should trigger here, but the die isn't catched by this eval
 263   die "failed\n";
 264  };
 265  is $@, "reaped\n", 'die in reap at eval [ok - $@]';
 266  is $x, 1, 'die in reap at eval [ok - x]';
 267  is $y, 1, 'die in reap at eval [ok - y]';
 268 }
 269
 270 $y = undef;
 271 {
 272  local $x = 1;
 273  eval {
 274   local $x = 2;
 275   {
 276    local $x = 3;
 277    reap { ++$y; die "reaped\n" } => HERE;
 278    is $x, 3,     'die in reap inside eval [not yet - x]';
 279    is $y, undef, 'die in reap inside eval [not yet - y]';
 280   } # should trigger here
 281   die "failed\n";
 282  };
 283  is $@, "reaped\n", 'die in reap inside eval [ok - $@]';
 284  is $x, 1, 'die in reap inside eval [ok - x]';
 285  is $y, 1, 'die in reap inside eval [ok - y]';
 286 }
 287
 288 sub hijacked {
 289  my ($cb, $desc) = @_;
 290  local $x = 2;
 291  sub {
 292   local $x = 3;
 293   &reap($cb => UP);
 294   is $x, 3,     "$desc [not yet 1 - x]";
 295   is $y, undef, "$desc [not yet 1 - y]";
 296  }->();
 297  is $x, 2,     "$desc [not yet 2 - x]";
 298  is $y, undef, "$desc [not yet 2 - y]";
 299  11, 12;
 300 }
 301
 302 for ([ sub { ++$y; 15, 16, 17, 18 },        'implicit ' ],
 303      [ sub { ++$y; return 15, 16, 17, 18 }, ''          ]) {
 304  my ($cb, $imp) = @$_;
 305  $imp = "RT #44204 - ${imp}return from reap";
 306  my $desc;
 307  $y = undef;
 308  {
 309   $desc = "$imp in list context";
 310   local $x = 1;
 311   my @l = hijacked($cb, $desc);
 312   is $x,         1,          "$desc [ok - x]";
 313   is $y,         1,          "$desc [ok - y]";
 314   is_deeply \@l, [ 11, 12 ], "$desc [ok - l]";
 315  }
 316  $y = undef;
 317  {
 318   $desc = "$imp in list context";
 319   local $x = 1;
 320   my $s = hijacked($cb, $desc);
 321   is $x, 1,  "$desc [ok - x]";
 322   is $y, 1,  "$desc [ok - y]";
 323   is $s, 12, "$desc [ok - s]";
 324  }
 325 }