t/60-uplevel-target.t

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