Don't rely on being able to access the old context in su_uplevel_restore()

[perl/modules/Scope-Upper.git] / t / 60-uplevel-target.t

diff --git a/t/60-uplevel-target.t b/t/60-uplevel-target.t
index 246af7b351913f70ac67a1fb4a74cdc1e5b1ca1f..1dcf3251b71591ec061af186942079d9f5dd6436 100644 (file)
--- a/t/60-uplevel-target.t
+++ b/t/60-uplevel-target.t
@@ -3,7 +3,7 @@
 use strict;
 use warnings;
 
-use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5 + 6;
+use Test::More tests => (1 * 3 + 2 * 4 + 3 * 5) * 2 + 7 + 5 + 6 + 5 + 6 + 5;
 
 use Scope::Upper qw<uplevel HERE UP TOP>;
 
@@ -253,4 +253,32 @@ sub four {
 
   is $destroyed, 0,  "$desc: code is destroyed";
  }
+
+ SKIP: {
+  skip 'This fails even with a plain subroutine call on 5.8.x' => 5
+                                                                if "$]" < 5.009;
+  local $@;
+  local $destroyed = 0;
+  my $desc = 'code destruction and goto';
+
+  {
+   my $lexical = 0;
+   my $cb = sub {
+    ++$lexical;
+    is $destroyed, 0, "$desc: not yet 1";
+   };
+   $cb = bless $cb, 'Scope::Upper::TestCodeDestruction';
+
+   eval {
+    sub {
+     &uplevel(sub { goto $cb } => HERE);
+     is $destroyed, 0, "$desc: not yet 2";
+    }->();
+   };
+   is $@,         '', "$desc: no error";
+   is $destroyed, 0,  "$desc: not yet 3";
+  }
+
+  is $destroyed, 1, "$desc: code is destroyed";
+ }
 }