t/60-uplevel-target.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5 + 6 + 5;
   7
   8 use Scope::Upper qw<uplevel HERE UP TOP>;
   9
  10 our ($desc, $target);
  11
  12 my @cxt;
  13
  14 sub three {
  15  my ($depth, $code) = @_;
  16  $cxt[0] = HERE;
  17  $target = $cxt[$depth];
  18  &uplevel($code => $target);
  19  pass("$desc: reached end of three()");
  20 }
  21
  22 my $two = sub {
  23  $cxt[1] = HERE;
  24  three(@_);
  25  pass("$desc: reached end of \$two");
  26 };
  27
  28 sub one {
  29  $cxt[2] = HERE;
  30  $two->(@_);
  31  pass("$desc: reached end of one()");
  32 }
  33
  34 sub tester_sub {
  35  is(HERE, $target, "$desc: right context");
  36 }
  37
  38 my $tester_anon = sub {
  39  is(HERE, $target, "$desc: right context");
  40 };
  41
  42 my @subs = (\&three, $two, \&one);
  43
  44 for my $height (0 .. 2) {
  45  my $base = $subs[$height];
  46
  47  for my $anon (0, 1) {
  48   my $code = $anon ? $tester_anon : \&tester_sub;
  49
  50   for my $depth (0 .. $height) {
  51    local $target;
  52    local $desc = "uplevel at depth $depth/$height";
  53    $desc .= $anon ? ' (anonymous callback)' : ' (named callback)';
  54
  55    local $@;
  56    eval { $base->($depth, $code) };
  57    is $@, '', "$desc: no error";
  58   }
  59  }
  60 }
  61
  62 {
  63  my $desc = 'uplevel called without a code reference';
  64  local $@;
  65  eval {
  66   three(0, "wut");
  67   fail "$desc: uplevel should have croaked";
  68  };
  69  like $@, qr/^First argument to uplevel must be a code reference/,"$desc: dies";
  70 }
  71
  72 sub four {
  73  my $desc = shift;
  74  my $cxt  = HERE;
  75  uplevel { is HERE, $cxt, "$desc: right context" };
  76  pass "$desc: reached end of four()";
  77 }
  78
  79 {
  80  my $desc = 'uplevel called without a target';
  81  local $@;
  82  eval {
  83   four($desc);
  84  };
  85  is $@, '', "$desc: no error";
  86 }
  87
  88 {
  89  my $desc = 'uplevel to top';
  90  local $@;
  91  eval {
  92   uplevel sub { fail "$desc: uplevel body should not be executed" }, TOP;
  93   fail "$desc: uplevel should have croaked";
  94  };
  95  like $@, qr/^Can't uplevel outside a subroutine/, "$desc: dies";
  96 }
  97
  98 {
  99  my $desc = 'uplevel to eval 1';
 100  local $@;
 101  eval {
 102   uplevel sub { fail "$desc: uplevel body should not be executed" }, HERE;
 103   fail "$desc: uplevel should have croaked";
 104  };
 105  like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
 106 }
 107
 108 {
 109  my $desc = 'uplevel to eval 2';
 110  local $@;
 111  sub {
 112   eval {
 113    uplevel {
 114     fail "$desc: uplevel body should not be executed"
 115    };
 116    fail "$desc: uplevel should have croaked";
 117   };
 118   return;
 119  }->();
 120  like $@, qr/^Can't uplevel to an eval frame/, "$desc: dies";
 121 }
 122
 123 # Target destruction
 124
 125 {
 126  our $destroyed;
 127  sub Scope::Upper::TestCodeDestruction::DESTROY { ++$destroyed }
 128
 129  {
 130   local $@;
 131   local $destroyed = 0;
 132   my $desc = 'target destruction 1';
 133
 134   {
 135    my $lexical;
 136    my $target = sub {
 137     my $code = shift;
 138     ++$lexical;
 139     $code->();
 140    };
 141    $target = bless $target, 'Scope::Upper::TestCodeDestruction';
 142
 143    eval {
 144     $target->(
 145      sub {
 146       uplevel {
 147        is $destroyed, 0, "$desc: not yet 1";
 148       } UP;
 149       is $destroyed, 0, "$desc: not yet 2";
 150      },
 151     );
 152    };
 153    is $@,         '', "$desc: no error";
 154    is $destroyed, 0,  "$desc: not yet 3";
 155   }
 156
 157   is $destroyed, 1, "$desc: target is detroyed";
 158  }
 159
 160  SKIP: {
 161   skip 'This fails even with a plain subroutine call on 5.8.x' => 6
 162                                                                 if "$]" < 5.009;
 163   local $@;
 164   local $destroyed = 0;
 165   my $desc = 'target destruction 2';
 166
 167   {
 168    my $lexical;
 169    my $target = sub {
 170     my $code = shift;
 171     ++$lexical;
 172     $code->();
 173    };
 174    $target = bless $target, 'Scope::Upper::TestCodeDestruction';
 175
 176    eval {
 177     $target->(
 178      sub {
 179       uplevel {
 180        $target->(sub {
 181         is $destroyed, 0, "$desc: not yet 1";
 182        });
 183        is $destroyed, 0, "$desc: not yet 2";
 184       } UP;
 185       is $destroyed, 0, "$desc: not yet 3";
 186      },
 187     );
 188    };
 189    is $@,         '', "$desc: no error";
 190    is $destroyed, 0,  "$desc: not yet 4";
 191   }
 192
 193   is $destroyed, 1, "$desc: target is detroyed";
 194  }
 195
 196  {
 197   local $@;
 198   local $destroyed = 0;
 199   my $desc = 'target destruction 3';
 200
 201   {
 202    my $lexical;
 203    my $target = sub {
 204     ++$lexical;
 205     if (@_) {
 206      my $code = shift;
 207      $code->();
 208     } else {
 209      is $destroyed, 0, "$desc: not yet 1";
 210     }
 211    };
 212    $target = bless $target, 'Scope::Upper::TestCodeDestruction';
 213
 214    eval {
 215     $target->(
 216      sub {
 217       &uplevel($target => UP);
 218       is $destroyed, 0, "$desc: not yet 2";
 219      },
 220     );
 221    };
 222    is $@,         '', "$desc: no error";
 223    is $destroyed, 0,  "$desc: not yet 3";
 224   }
 225
 226   is $destroyed, 1, "$desc: target is detroyed";
 227  }
 228
 229  {
 230   local $@;
 231   local $destroyed = 0;
 232   my $desc = 'code destruction';
 233
 234   {
 235    my $lexical;
 236    my $code = sub {
 237     ++$lexical;
 238     is $destroyed, 0, "$desc: not yet 1";
 239    };
 240
 241    eval {
 242     sub {
 243      sub {
 244       &uplevel($code, UP);
 245       is $destroyed, 0, "$desc: not yet 2";
 246      }->();
 247      is $destroyed, 0, "$desc: not yet 2";
 248     }->();
 249    };
 250    is $@,         '', "$desc: no error";
 251    is $destroyed, 0,  "$desc: not yet 3";
 252   };
 253
 254   is $destroyed, 0,  "$desc: code is destroyed";
 255  }
 256
 257  SKIP: {
 258   skip 'This fails even with a plain subroutine call on 5.8.x' => 5
 259                                                                 if "$]" < 5.009;
 260   local $@;
 261   local $destroyed = 0;
 262   my $desc = 'code destruction and goto';
 263
 264   {
 265    my $lexical = 0;
 266    my $cb = sub {
 267     ++$lexical;
 268     is $destroyed, 0, "$desc: not yet 1";
 269    };
 270    $cb = bless $cb, 'Scope::Upper::TestCodeDestruction';
 271
 272    eval {
 273     sub {
 274      &uplevel(sub { goto $cb } => HERE);
 275      is $destroyed, 0, "$desc: not yet 2";
 276     }->();
 277    };
 278    is $@,         '', "$desc: no error";
 279    is $destroyed, 0,  "$desc: not yet 3";
 280   }
 281
 282   is $destroyed, 1, "$desc: code is destroyed";
 283  }
 284 }