--- /dev/null
+#!perl -T
+
+use strict;
+use warnings;
+
+use Test::More tests => 3 + (3 + 4 + 4) + (3 + 4 + 4) + 5 + 3*3 + (4 + 7);
+
+use Scope::Upper qw<uplevel HERE SUB CALLER>;
+
+sub depth {
+ my $depth = 0;
+ while (1) {
+ my @c = caller($depth);
+ last unless @c;
+ ++$depth;
+ }
+ return $depth - 1;
+}
+
+is depth(), 0, 'check top depth';
+is sub { depth() }->(), 1, 'check subroutine call depth';
+is do { local $@; eval { depth() } }, 1, 'check eval block depth';
+
+{
+ my $desc = 'exception with no eval in between 1';
+ local $@;
+ eval {
+ sub {
+ is depth(), 2, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 2";
+ die 'cabbage';
+ };
+ fail "$desc: not reached 1";
+ }->();
+ fail "$desc: not reached 2";
+ };
+ my $line = __LINE__-6;
+ like $@, qr/^cabbage at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with no eval in between 2';
+ local $@;
+ eval {
+ sub {
+ is depth(), 2, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 2";
+ sub {
+ is depth(), 3, "$desc: correct depth 3";
+ die 'lettuce';
+ }->();
+ };
+ fail "$desc: not reached 1";
+ }->();
+ fail "$desc: not reached 2";
+ };
+ my $line = __LINE__-7;
+ like $@, qr/^lettuce at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with no eval in between 3';
+ local $@;
+ eval q[
+ sub {
+ is depth(), 2, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 2";
+ sub {
+ is depth(), 3, "$desc: correct depth 3";
+ die 'onion';
+ }->();
+ };
+ fail "$desc: not reached 1";
+ }->();
+ fail "$desc: not reached 2";
+ ];
+ like $@, qr/^onion at \(eval \d+\) line 8/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with an eval in between 1';
+ local $@;
+ eval {
+ sub {
+ eval {
+ is depth(), 3, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 2";
+ die 'macaroni';
+ } SUB;
+ fail "$desc: not reached 1";
+ };
+ fail "$desc: not reached 2";
+ }->();
+ fail "$desc: not reached 3";
+ };
+ my $line = __LINE__-8;
+ like $@, qr/^macaroni at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with an eval in between 2';
+ local $@;
+ eval {
+ sub {
+ eval {
+ is depth(), 3, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 1";
+ sub {
+ is depth(), 3, "$desc: correct depth 1";
+ die 'spaghetti';
+ }->();
+ } SUB;
+ fail "$desc: not reached 1";
+ };
+ fail "$desc: not reached 2";
+ }->();
+ fail "$desc: not reached 3";
+ };
+ my $line = __LINE__-9;
+ like $@, qr/^spaghetti at \Q$0\E line $line/, "$desc: correct exception";
+}
+
+{
+ my $desc = 'exception with an eval in between 3';
+ local $@;
+ eval {
+ sub {
+ eval q[
+ is depth(), 3, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 1";
+ sub {
+ is depth(), 3, "$desc: correct depth 1";
+ die 'ravioli';
+ }->();
+ } SUB;
+ fail "$desc: not reached 1";
+ ];
+ fail "$desc: not reached 2";
+ }->();
+ fail "$desc: not reached 3";
+ };
+ like $@, qr/^ravioli at \(eval \d+\) line 7/, "$desc: correct exception";
+}
+our $hurp;
+
+SKIP: {
+ skip "Causes failures during global destruction on perl 5.8.[0126]" => 5
+ if ("$]" >= 5.008 and "$]" <= 5.008002) or "$]" == 5.008006;
+ my $desc = 'exception with an eval and a local $@ in between';
+ local $hurp = 'durp';
+ local $@;
+ my $x = (eval {
+ sub {
+ local $@;
+ eval {
+ sub {
+ is depth(), 4, "$desc: correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc: correct depth 2";
+ die 'lasagna'
+ } CALLER(2);
+ fail "$desc: not reached 1";
+ }->();
+ fail "$desc: not reached 2";
+ };
+ fail "$desc: not reached 3";
+ }->();
+ fail "$desc: not reached 4";
+ }, $@);
+ my $line = __LINE__-10;
+ like $@, qr/^lasagna at \Q$0\E line $line/, "$desc: correct exception";
+ like $x, qr/^lasagna at \Q$0\E line $line/, "$desc: \$@ timely reset";
+ is $hurp, 'durp', "$desc: force save stack flushing didn't go too far";
+}
+
+{
+ my $desc = 'several exceptions in a row';
+ local $@;
+ eval {
+ sub {
+ is depth(), 2, "$desc (first): correct depth";
+ uplevel {
+ is depth(), 2, "$desc (first): correct depth";
+ die 'carrot';
+ };
+ fail "$desc (first): not reached 1";
+ }->();
+ fail "$desc (first): not reached 2";
+ };
+ my $line = __LINE__-6;
+ like $@, qr/^carrot at \Q$0\E line $line/, "$desc (first): correct exception";
+ eval {
+ sub {
+ is depth(), 2, "$desc (second): correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc (second): correct depth 2";
+ die 'potato';
+ };
+ fail "$desc (second): not reached 1";
+ }->();
+ fail "$desc (second): not reached 2";
+ };
+ $line = __LINE__-6;
+ like $@, qr/^potato at \Q$0\E line $line/, "$desc (second): correct exception";
+ eval {
+ sub {
+ is depth(), 2, "$desc (third): correct depth 1";
+ uplevel {
+ is depth(), 2, "$desc (third): correct depth 2";
+ die 'tomato';
+ };
+ fail "$desc (third): not reached 1";
+ }->();
+ fail "$desc (third): not reached 2";
+ };
+ $line = __LINE__-6;
+ like $@, qr/^tomato at \Q$0\E line $line/, "$desc (third): correct exception";
+}
+
+my $has_B = do { local $@; eval 'require B; 1' };
+
+sub check_depth {
+ my ($code, $expected, $desc) = @_;
+
+ SKIP: {
+ skip 'B.pm is needed to check CV depth' => 1 unless $has_B;
+
+ local $Test::Builder::Level = ($Test::Builder::Level || 0) + 1;
+
+ my $depth = B::svref_2object($code)->DEPTH;
+ is $depth, $expected, $desc;
+ }
+}
+
+sub bonk {
+ my ($code, $n, $cxt) = @_;
+ $cxt = SUB unless defined $cxt;
+ if ($n) {
+ bonk($code, $n - 1, $cxt);
+ } else {
+ &uplevel($code, $cxt);
+ }
+}
+
+{
+ my $desc = "an exception unwinding several levels of the same sub 1";
+ local $@;
+ check_depth \&bonk, 0, "$desc: depth at the beginning";
+ my $rec = 7;
+ sub {
+ eval {
+ bonk(sub {
+ check_depth \&bonk, $rec + 1, "$desc: depth inside";
+ die 'pepperoni';
+ }, $rec);
+ }
+ }->();
+ my $line = __LINE__-4;
+ like $@, qr/^pepperoni at \Q$0\E line $line/, "$desc: correct exception";
+ check_depth \&bonk, 0, "$desc: depth at the end";
+}
+
+sub clash {
+ my ($pre, $rec, $desc, $cxt, $m, $n) = @_;
+ $m = 0 unless defined $m;
+ if ($m < $pre) {
+ clash($pre, $rec, $desc, $cxt, $m + 1, $n);
+ } elsif ($m == $pre) {
+ check_depth \&clash, $pre + 1, "$desc: depth after prepending frames";
+ eval {
+ clash($pre, $rec, $desc, $cxt, $pre + 1, $n);
+ };
+ my $line = __LINE__+11;
+ like $@, qr/^garlic at \Q$0\E line $line/, "$desc: correct exception";
+ check_depth \&clash, $pre + 1, "$desc: depth after unwinding";
+ } else {
+ $n = 0 unless defined $n;
+ $cxt = SUB unless defined $cxt;
+ if ($n < $rec) {
+ clash($pre, $rec, $desc, $cxt, $m, $n + 1);
+ } else {
+ uplevel {
+ check_depth \&clash, $pre + 1 + $rec + 1, "$desc: depth inside";
+ die 'garlic';
+ } $cxt;
+ }
+ }
+}
+
+{
+ my $desc = "an exception unwinding several levels of the same sub 2";
+ local $@;
+ check_depth \&clash, 0, "$desc: depth at the beginning";
+ my $pre = 5;
+ my $rec = 10;
+ sub {
+ eval {
+ clash($pre, $rec, $desc);
+ }
+ }->();
+ is $@, '', "$desc: no exception outside";
+ check_depth \&clash, 0, "$desc: depth at the beginning";
+}
projects / perl / modules / Scope-Upper.git / blobdiff