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  my $loc = $^P ? "[$0:" . (__LINE__-14) . ']' : '';
  81  like $@, qr/^onion at \(eval \d+\)\Q$loc\E line 8/, "$desc: correct exception";
  82 }
  83
  84 {
  85  my $desc = 'exception with an eval in between 1';
  86  local $@;
  87  eval {
  88   sub {
  89    eval {
  90     is depth(), 3, "$desc: correct depth 1";
  91     uplevel {
  92      is depth(), 2, "$desc: correct depth 2";
  93      die 'macaroni';
  94     } SUB;
  95     fail "$desc: not reached 1";
  96    };
  97    fail "$desc: not reached 2";
  98   }->();
  99   fail "$desc: not reached 3";
 100  };
 101  my $line = __LINE__-8;
 102  like $@, qr/^macaroni at \Q$0\E line $line/, "$desc: correct exception";
 103 }
 104
 105 {
 106  my $desc = 'exception with an eval in between 2';
 107  local $@;
 108  eval {
 109   sub {
 110    eval {
 111     is depth(), 3, "$desc: correct depth 1";
 112     uplevel {
 113      is depth(), 2, "$desc: correct depth 1";
 114      sub {
 115       is depth(), 3, "$desc: correct depth 1";
 116       die 'spaghetti';
 117      }->();
 118     } SUB;
 119     fail "$desc: not reached 1";
 120    };
 121    fail "$desc: not reached 2";
 122   }->();
 123   fail "$desc: not reached 3";
 124  };
 125  my $line = __LINE__-9;
 126  like $@, qr/^spaghetti at \Q$0\E line $line/, "$desc: correct exception";
 127 }
 128
 129 {
 130  my $desc = 'exception with an eval in between 3';
 131  local $@;
 132  eval {
 133   sub {
 134    eval q[
 135     is depth(), 3, "$desc: correct depth 1";
 136     uplevel {
 137      is depth(), 2, "$desc: correct depth 1";
 138      sub {
 139       is depth(), 3, "$desc: correct depth 1";
 140       die 'ravioli';
 141      }->();
 142     } SUB;
 143     fail "$desc: not reached 1";
 144     ];
 145    fail "$desc: not reached 2";
 146   }->();
 147   fail "$desc: not reached 3";
 148  };
 149  my $loc = $^P ? "[$0:" . (__LINE__-15) . ']' : '';
 150  like $@, qr/^ravioli at \(eval \d+\)\Q$loc\E line 7/,
 151                                                      "$desc: correct exception";
 152 }
 153 our $hurp;
 154
 155 SKIP: {
 156  skip "Causes failures during global destruction on perl 5.8.[0-6]" => 5
 157                                          if "$]" >= 5.008 and "$]" <= 5.008_006;
 158  my $desc = 'exception with an eval and a local $@ in between';
 159  local $hurp = 'durp';
 160  local $@;
 161  my $x = (eval {
 162   sub {
 163    local $@;
 164    eval {
 165     sub {
 166      is depth(), 4, "$desc: correct depth 1";
 167      uplevel {
 168       is depth(), 2, "$desc: correct depth 2";
 169       die 'lasagna'
 170      } CALLER(2);
 171      fail "$desc: not reached 1";
 172     }->();
 173     fail "$desc: not reached 2";
 174    };
 175    fail "$desc: not reached 3";
 176   }->();
 177   fail "$desc: not reached 4";
 178  }, $@);
 179  my $line = __LINE__-10;
 180  like $@, qr/^lasagna at \Q$0\E line $line/, "$desc: correct exception";
 181  like $x, qr/^lasagna at \Q$0\E line $line/, "$desc: \$@ timely reset";
 182  is $hurp, 'durp', "$desc: force save stack flushing didn't go too far";
 183 }
 184
 185 {
 186  my $desc = 'several exceptions in a row';
 187  local $@;
 188  eval {
 189   sub {
 190    is depth(), 2, "$desc (first): correct depth";
 191    uplevel {
 192     is depth(), 2, "$desc (first): correct depth";
 193     die 'carrot';
 194    };
 195    fail "$desc (first): not reached 1";
 196   }->();
 197   fail "$desc (first): not reached 2";
 198  };
 199  my $line = __LINE__-6;
 200  like $@, qr/^carrot at \Q$0\E line $line/, "$desc (first): correct exception";
 201  eval {
 202   sub {
 203    is depth(), 2, "$desc (second): correct depth 1";
 204    uplevel {
 205     is depth(), 2, "$desc (second): correct depth 2";
 206     die 'potato';
 207    };
 208    fail "$desc (second): not reached 1";
 209   }->();
 210   fail "$desc (second): not reached 2";
 211  };
 212  $line = __LINE__-6;
 213  like $@, qr/^potato at \Q$0\E line $line/, "$desc (second): correct exception";
 214  eval {
 215   sub {
 216    is depth(), 2, "$desc (third): correct depth 1";
 217    uplevel {
 218     is depth(), 2, "$desc (third): correct depth 2";
 219     die 'tomato';
 220    };
 221    fail "$desc (third): not reached 1";
 222   }->();
 223   fail "$desc (third): not reached 2";
 224  };
 225  $line = __LINE__-6;
 226  like $@, qr/^tomato at \Q$0\E line $line/, "$desc (third): correct exception";
 227 }
 228
 229 my $has_B = do { local $@; eval { require B; 1 } };
 230
 231 sub check_depth {
 232  my ($code, $expected, $desc) = @_;
 233
 234  SKIP: {
 235   skip 'B.pm is needed to check CV depth' => 1 unless $has_B;
 236
 237   local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
 238
 239   my $depth = B::svref_2object($code)->DEPTH;
 240   is $depth, $expected, $desc;
 241  }
 242 }
 243
 244 sub bonk {
 245  my ($code, $n, $cxt) = @_;
 246  $cxt = SUB unless defined $cxt;
 247  if ($n) {
 248   bonk($code, $n - 1, $cxt);
 249  } else {
 250   &uplevel($code, $cxt);
 251  }
 252 }
 253
 254 {
 255  my $desc = "an exception unwinding several levels of the same sub 1";
 256  local $@;
 257  check_depth \&bonk, 0, "$desc: depth at the beginning";
 258  my $rec = 7;
 259  sub {
 260   eval {
 261    bonk(sub {
 262     check_depth \&bonk, $rec + 1, "$desc: depth inside";
 263     die 'pepperoni';
 264    }, $rec);
 265   }
 266  }->();
 267  my $line = __LINE__-4;
 268  like $@, qr/^pepperoni at \Q$0\E line $line/, "$desc: correct exception";
 269  check_depth \&bonk, 0, "$desc: depth at the end";
 270 }
 271
 272 sub clash {
 273  my ($pre, $rec, $desc, $cxt, $m, $n) = @_;
 274  $m = 0 unless defined $m;
 275  if ($m < $pre) {
 276   clash($pre, $rec, $desc, $cxt, $m + 1, $n);
 277  } elsif ($m == $pre) {
 278   check_depth \&clash, $pre + 1, "$desc: depth after prepending frames";
 279   eval {
 280    clash($pre, $rec, $desc, $cxt, $pre + 1, $n);
 281   };
 282   my $line = __LINE__+11;
 283   like $@, qr/^garlic at \Q$0\E line $line/, "$desc: correct exception";
 284   check_depth \&clash, $pre + 1, "$desc: depth after unwinding";
 285  } else {
 286   $n   = 0   unless defined $n;
 287   $cxt = SUB unless defined $cxt;
 288   if ($n < $rec) {
 289    clash($pre, $rec, $desc, $cxt, $m, $n + 1);
 290   } else {
 291    uplevel {
 292     check_depth \&clash, $pre + 1 + $rec + 1, "$desc: depth inside";
 293     die 'garlic';
 294    } $cxt;
 295   }
 296  }
 297 }
 298
 299 {
 300  my $desc = "an exception unwinding several levels of the same sub 2";
 301  local $@;
 302  check_depth \&clash, 0, "$desc: depth at the beginning";
 303  my $pre = 5;
 304  my $rec = 10;
 305  sub {
 306   eval {
 307    clash($pre, $rec, $desc);
 308   }
 309  }->();
 310  is $@, '', "$desc: no exception outside";
 311  check_depth \&clash, 0, "$desc: depth at the beginning";
 312 }
 313
 314 # XS
 315
 316 {
 317  my $desc = 'exception thrown from XS';
 318  local $@;
 319  eval {
 320   sub {
 321    &uplevel(\&uplevel => \1, HERE);
 322   }->();
 323  };
 324  my $line = $^P ? '\d+' : __LINE__-2; # The error happens at the target frame.
 325  my $file = $^P ? '\S+' : quotemeta $0;
 326  like $@,
 327    qr/^First argument to uplevel must be a code reference at $file line $line/,
 328    "$desc: correct error";
 329 }