t/13-reap-ctl.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 28;
   7
   8 use Scope::Upper qw/reap/;
   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 => 1;
  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 => 2;
  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 => 3;
  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 => 2;
  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 => 1;
 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 }