t/63-uplevel-ctl.t

   1 #!perl -T
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 3 + (3 + 4 + 4) + (3 + 4 + 4) + 5 + 3*3 + (4 + 7) + 1;
   7
   8 use Scope::Upper qw<uplevel HERE SUB CALLER>;
   9
  10 sub depth {
  11  my $depth = 0;
  12  while (1) {
  13   my @c = caller($depth);
  14   last unless @c;
  15   ++$depth;
  16  }
  17  return $depth - 1;
  18 }
  19
  20 is depth(),                           0, 'check top depth';
  21 is sub { depth() }->(),               1, 'check subroutine call depth';
  22 is do { local $@; eval { depth() } }, 1, 'check eval block depth';
  23
  24 {
  25  my $desc = 'exception with no eval in between 1';
  26  local $@;
  27  eval {
  28   sub {
  29    is depth(), 2, "$desc: correct depth 1";
  30    uplevel {
  31     is depth(), 2, "$desc: correct depth 2";
  32     die 'cabbage';
  33    };
  34    fail "$desc: not reached 1";
  35   }->();
  36   fail "$desc: not reached 2";
  37  };
  38  my $line = __LINE__-6;
  39  like $@, qr/^cabbage at \Q$0\E line $line/, "$desc: correct exception";
  40 }
  41
  42 {
  43  my $desc = 'exception with no eval in between 2';
  44  local $@;
  45  eval {
  46   sub {
  47    is depth(), 2, "$desc: correct depth 1";
  48    uplevel {
  49     is depth(), 2, "$desc: correct depth 2";
  50     sub {
  51      is depth(), 3, "$desc: correct depth 3";
  52      die 'lettuce';
  53     }->();
  54    };
  55    fail "$desc: not reached 1";
  56   }->();
  57   fail "$desc: not reached 2";
  58  };
  59  my $line = __LINE__-7;
  60  like $@, qr/^lettuce at \Q$0\E line $line/, "$desc: correct exception";
  61 }
  62
  63 {
  64  my $desc = 'exception with no eval in between 3';
  65  local $@;
  66  eval q[
  67   sub {
  68    is depth(), 2, "$desc: correct depth 1";
  69    uplevel {
  70     is depth(), 2, "$desc: correct depth 2";
  71     sub {
  72      is depth(), 3, "$desc: correct depth 3";
  73      die 'onion';
  74     }->();
  75    };
  76    fail "$desc: not reached 1";
  77   }->();
  78   fail "$desc: not reached 2";
  79  ];
  80  like $@, qr/^onion at \(eval \d+\) line 8/, "$desc: correct exception";
  81 }
  82
  83 {
  84  my $desc = 'exception with an eval in between 1';
  85  local $@;
  86  eval {
  87   sub {
  88    eval {
  89     is depth(), 3, "$desc: correct depth 1";
  90     uplevel {
  91      is depth(), 2, "$desc: correct depth 2";
  92      die 'macaroni';
  93     } SUB;
  94     fail "$desc: not reached 1";
  95    };
  96    fail "$desc: not reached 2";
  97   }->();
  98   fail "$desc: not reached 3";
  99  };
 100  my $line = __LINE__-8;
 101  like $@, qr/^macaroni at \Q$0\E line $line/, "$desc: correct exception";
 102 }
 103
 104 {
 105  my $desc = 'exception with an eval in between 2';
 106  local $@;
 107  eval {
 108   sub {
 109    eval {
 110     is depth(), 3, "$desc: correct depth 1";
 111     uplevel {
 112      is depth(), 2, "$desc: correct depth 1";
 113      sub {
 114       is depth(), 3, "$desc: correct depth 1";
 115       die 'spaghetti';
 116      }->();
 117     } SUB;
 118     fail "$desc: not reached 1";
 119    };
 120    fail "$desc: not reached 2";
 121   }->();
 122   fail "$desc: not reached 3";
 123  };
 124  my $line = __LINE__-9;
 125  like $@, qr/^spaghetti at \Q$0\E line $line/, "$desc: correct exception";
 126 }
 127
 128 {
 129  my $desc = 'exception with an eval in between 3';
 130  local $@;
 131  eval {
 132   sub {
 133    eval q[
 134     is depth(), 3, "$desc: correct depth 1";
 135     uplevel {
 136      is depth(), 2, "$desc: correct depth 1";
 137      sub {
 138       is depth(), 3, "$desc: correct depth 1";
 139       die 'ravioli';
 140      }->();
 141     } SUB;
 142     fail "$desc: not reached 1";
 143     ];
 144    fail "$desc: not reached 2";
 145   }->();
 146   fail "$desc: not reached 3";
 147  };
 148  like $@, qr/^ravioli at \(eval \d+\) line 7/, "$desc: correct exception";
 149 }
 150 our $hurp;
 151
 152 SKIP: {
 153  skip "Causes failures during global destruction on perl 5.8.[0126]" => 5
 154                     if ("$]" >= 5.008 and "$]" <= 5.008002) or "$]" == 5.008006;
 155  my $desc = 'exception with an eval and a local $@ in between';
 156  local $hurp = 'durp';
 157  local $@;
 158  my $x = (eval {
 159   sub {
 160    local $@;
 161    eval {
 162     sub {
 163      is depth(), 4, "$desc: correct depth 1";
 164      uplevel {
 165       is depth(), 2, "$desc: correct depth 2";
 166       die 'lasagna'
 167      } CALLER(2);
 168      fail "$desc: not reached 1";
 169     }->();
 170     fail "$desc: not reached 2";
 171    };
 172    fail "$desc: not reached 3";
 173   }->();
 174   fail "$desc: not reached 4";
 175  }, $@);
 176  my $line = __LINE__-10;
 177  like $@, qr/^lasagna at \Q$0\E line $line/, "$desc: correct exception";
 178  like $x, qr/^lasagna at \Q$0\E line $line/, "$desc: \$@ timely reset";
 179  is $hurp, 'durp', "$desc: force save stack flushing didn't go too far";
 180 }
 181
 182 {
 183  my $desc = 'several exceptions in a row';
 184  local $@;
 185  eval {
 186   sub {
 187    is depth(), 2, "$desc (first): correct depth";
 188    uplevel {
 189     is depth(), 2, "$desc (first): correct depth";
 190     die 'carrot';
 191    };
 192    fail "$desc (first): not reached 1";
 193   }->();
 194   fail "$desc (first): not reached 2";
 195  };
 196  my $line = __LINE__-6;
 197  like $@, qr/^carrot at \Q$0\E line $line/, "$desc (first): correct exception";
 198  eval {
 199   sub {
 200    is depth(), 2, "$desc (second): correct depth 1";
 201    uplevel {
 202     is depth(), 2, "$desc (second): correct depth 2";
 203     die 'potato';
 204    };
 205    fail "$desc (second): not reached 1";
 206   }->();
 207   fail "$desc (second): not reached 2";
 208  };
 209  $line = __LINE__-6;
 210  like $@, qr/^potato at \Q$0\E line $line/, "$desc (second): correct exception";
 211  eval {
 212   sub {
 213    is depth(), 2, "$desc (third): correct depth 1";
 214    uplevel {
 215     is depth(), 2, "$desc (third): correct depth 2";
 216     die 'tomato';
 217    };
 218    fail "$desc (third): not reached 1";
 219   }->();
 220   fail "$desc (third): not reached 2";
 221  };
 222  $line = __LINE__-6;
 223  like $@, qr/^tomato at \Q$0\E line $line/, "$desc (third): correct exception";
 224 }
 225
 226 my $has_B = do { local $@; eval 'require B; 1' };
 227
 228 sub check_depth {
 229  my ($code, $expected, $desc) = @_;
 230
 231  SKIP: {
 232   skip 'B.pm is needed to check CV depth' => 1 unless $has_B;
 233
 234   local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
 235
 236   my $depth = B::svref_2object($code)->DEPTH;
 237   is $depth, $expected, $desc;
 238  }
 239 }
 240
 241 sub bonk {
 242  my ($code, $n, $cxt) = @_;
 243  $cxt = SUB unless defined $cxt;
 244  if ($n) {
 245   bonk($code, $n - 1, $cxt);
 246  } else {
 247   &uplevel($code, $cxt);
 248  }
 249 }
 250
 251 {
 252  my $desc = "an exception unwinding several levels of the same sub 1";
 253  local $@;
 254  check_depth \&bonk, 0, "$desc: depth at the beginning";
 255  my $rec = 7;
 256  sub {
 257   eval {
 258    bonk(sub {
 259     check_depth \&bonk, $rec + 1, "$desc: depth inside";
 260     die 'pepperoni';
 261    }, $rec);
 262   }
 263  }->();
 264  my $line = __LINE__-4;
 265  like $@, qr/^pepperoni at \Q$0\E line $line/, "$desc: correct exception";
 266  check_depth \&bonk, 0, "$desc: depth at the end";
 267 }
 268
 269 sub clash {
 270  my ($pre, $rec, $desc, $cxt, $m, $n) = @_;
 271  $m = 0 unless defined $m;
 272  if ($m < $pre) {
 273   clash($pre, $rec, $desc, $cxt, $m + 1, $n);
 274  } elsif ($m == $pre) {
 275   check_depth \&clash, $pre + 1, "$desc: depth after prepending frames";
 276   eval {
 277    clash($pre, $rec, $desc, $cxt, $pre + 1, $n);
 278   };
 279   my $line = __LINE__+11;
 280   like $@, qr/^garlic at \Q$0\E line $line/, "$desc: correct exception";
 281   check_depth \&clash, $pre + 1, "$desc: depth after unwinding";
 282  } else {
 283   $n   = 0   unless defined $n;
 284   $cxt = SUB unless defined $cxt;
 285   if ($n < $rec) {
 286    clash($pre, $rec, $desc, $cxt, $m, $n + 1);
 287   } else {
 288    uplevel {
 289     check_depth \&clash, $pre + 1 + $rec + 1, "$desc: depth inside";
 290     die 'garlic';
 291    } $cxt;
 292   }
 293  }
 294 }
 295
 296 {
 297  my $desc = "an exception unwinding several levels of the same sub 2";
 298  local $@;
 299  check_depth \&clash, 0, "$desc: depth at the beginning";
 300  my $pre = 5;
 301  my $rec = 10;
 302  sub {
 303   eval {
 304    clash($pre, $rec, $desc);
 305   }
 306  }->();
 307  is $@, '', "$desc: no exception outside";
 308  check_depth \&clash, 0, "$desc: depth at the beginning";
 309 }
 310
 311 # XS
 312
 313 {
 314  my $desc = 'exception thrown from XS';
 315  local $@;
 316  eval {
 317   sub {
 318    &uplevel(\&uplevel => \1, HERE);
 319   }->();
 320  };
 321  my $line = __LINE__-2; # The error happens at the target frame.
 322  like $@,
 323    qr/^First argument to uplevel must be a code reference at \Q$0\E line $line/,
 324    "$desc: correct error";
 325 }