Fix numerous localizations in the same scope not happening

diff --git a/MANIFEST b/MANIFEST
index c595b35a657a04137bd895fe9a7a877a135dc464..6ca644abb1ee001e7e86d557826f1729e904b4bb 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -15,19 +15,23 @@ t/11-reap-level.t
 t/12-reap-block.t
 t/13-reap-ctl.t
 t/15-reap-multi.t
+t/16-reap-numerous.t
 t/20-localize-target.t
 t/21-localize-level.t
 t/22-localize-block.t
 t/23-localize-ctl.t
 t/24-localize-magic.t
 t/25-localize-multi.t
+t/26-localize-numerous.t
 t/30-localize_elem-target.t
 t/31-localize_elem-level.t
 t/32-localize_elem-block.t
 t/34-localize_elem-magic.t
+t/36-localize_elem-numerous.t
 t/40-localize_delete-target.t
 t/41-localize_delete-level.t
 t/44-localize_delete-magic.t
+t/46-localize_delete-numerous.t
 t/50-unwind-target.t
 t/55-unwind-multi.t
 t/56-unwind-context.t

diff --git a/Upper.xs b/Upper.xs
index 20fa5d662013c10dc685bd656fee919a9753c3b9..ba8b7b4a53cf5599d9fb561482f42039d60e4514 100644 (file)
--- a/Upper.xs
+++ b/Upper.xs
@@ -114,8 +114,25 @@
 # define MY_CXT_CLONE NOOP
 #endif
 
+/* --- Global data --------------------------------------------------------- */
+
+#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
+
+typedef struct {
+ int stack_placeholder;
+ I32 cxix;
+ I32 items;
+ SV  **savesp;
+ OP  fakeop;
+} my_cxt_t;
+
+START_MY_CXT
+
 /* --- Stack manipulations ------------------------------------------------- */
 
+#define SU_SAVE_DESTRUCTOR_SIZE 3
+#define SU_SAVE_INT_SIZE        3
+
 #ifndef SvCANEXISTDELETE
 # define SvCANEXISTDELETE(sv) \
   (!SvRMAGICAL(sv)            \
@@ -259,11 +276,13 @@ STATIC void su_save_helem(pTHX_ HV *hv, SV *keysv, SV *val) {
 
 typedef struct {
  I32 depth;
+ I32 pad;
  I32 *origin;
  void (*handler)(pTHX_ void *);
 } su_ud_common;
 
 #define SU_UD_DEPTH(U)   (((su_ud_common *) (U))->depth)
+#define SU_UD_PAD(U)     (((su_ud_common *) (U))->pad)
 #define SU_UD_ORIGIN(U)  (((su_ud_common *) (U))->origin)
 #define SU_UD_HANDLER(U) (((su_ud_common *) (U))->handler)
 
@@ -518,8 +537,14 @@ STATIC void su_pop(pTHX_ void *ud) {
  SU_UD_DEPTH(ud) = --depth;
 
  if (depth > 0) {
-  I32 i = 1;
+  I32 i = 1, pad;
 
+  if (pad = SU_UD_PAD(ud)) {
+   dMY_CXT;
+   do {
+    save_int(&MY_CXT.stack_placeholder);
+   } while (--pad);
+  }
   SAVEDESTRUCTOR_X(su_pop, ud);
 
   /* Skip depths corresponding to scopes for which leave_scope() might not be
@@ -540,8 +565,8 @@ STATIC void su_pop(pTHX_ void *ud) {
   }
 
   SU_D(PerlIO_printf(Perl_debug_log,
-         "%p: set destructor  at depth=%2d scope_ix=%2d save_ix=%2d\n",
-          ud,                        depth, PL_scopestack_ix, PL_savestack_ix));
+          "%p: push destructor at depth=%2d scope_ix=%2d save_ix=%2d\n",
+           ud,                       depth, PL_scopestack_ix, PL_savestack_ix));
  } else {
   SU_UD_HANDLER(ud)(aTHX_ ud);
  }
@@ -551,28 +576,25 @@ STATIC void su_pop(pTHX_ void *ud) {
                      ud, PL_savestack_ix, PL_scopestack[PL_scopestack_ix]));
 }
 
-/* --- Global data --------------------------------------------------------- */
-
-#define MY_CXT_KEY __PACKAGE__ "::_guts" XS_VERSION
-
-typedef struct {
- int stack_placeholder;
- I32 cxix;
- I32 items;
- SV  **savesp;
- OP  fakeop;
-} my_cxt_t;
-
-START_MY_CXT
-
 /* --- Initialize the stack and the action userdata ------------------------ */
 
 STATIC I32 su_init(pTHX_ I32 cxix, void *ud, I32 size) {
 #define su_init(L, U, S) su_init(aTHX_ (L), (U), (S))
- I32 i, depth = 1, *origin;
+ I32 i, depth = 1, pad, offset, *origin;
 
  SU_D(PerlIO_printf(Perl_debug_log, "%p: ### init for cx %d\n", ud, cxix));
 
+ if (size <= SU_SAVE_DESTRUCTOR_SIZE)
+  pad = 0;
+ else {
+  I32 extra = size - SU_SAVE_DESTRUCTOR_SIZE;
+  pad = extra / SU_SAVE_INT_SIZE + ((extra % SU_SAVE_INT_SIZE) ? 1 : 0);
+ }
+ offset = SU_SAVE_DESTRUCTOR_SIZE + SU_SAVE_INT_SIZE * pad;
+
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: size=%d pad=%d offset=%d\n",
+                                     ud,    size,   pad,   offset));
+
  for (i = cxstack_ix; i > cxix; --i) {
   PERL_CONTEXT *cx = cxstack + i;
   switch (CxTYPE(cx)) {
@@ -606,7 +628,7 @@ STATIC I32 su_init(pTHX_ I32 cxix, void *ud, I32 size) {
     break;
   }
  }
- SU_D(PerlIO_printf(Perl_debug_log, "%p: depth is %d\n", ud, depth));
+ SU_D(PerlIO_printf(Perl_debug_log, "%p: going down to depth %d\n", ud, depth));
 
  Newx(origin, depth + 1, I32);
  origin[0] = PL_scopestack[PL_scopestack_ix - depth];
@@ -614,26 +636,30 @@ STATIC I32 su_init(pTHX_ I32 cxix, void *ud, I32 size) {
  for (i = depth - 1; i >= 1; --i) {
   I32 j = PL_scopestack_ix - i;
   origin[depth - i] = PL_scopestack[j];
-  PL_scopestack[j] += 3;
+  PL_scopestack[j] += offset;
  }
  origin[depth] = PL_savestack_ix;
 
  SU_UD_ORIGIN(ud) = origin;
  SU_UD_DEPTH(ud)  = depth;
-
- SU_D(PerlIO_printf(Perl_debug_log,
-        "%p: set original destructor at depth=%2d scope_ix=%2d save_ix=%2d\n",
-         ud,                     depth, PL_scopestack_ix - 1, PL_savestack_ix));
+ SU_UD_PAD(ud)    = pad;
 
  /* Make sure the first destructor fires by pushing enough fake slots on the
   * stack. */
- if (PL_savestack_ix + 3 <= PL_scopestack[PL_scopestack_ix - 1]) {
+ if (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
+                                       <= PL_scopestack[PL_scopestack_ix - 1]) {
   dMY_CXT;
   do {
+   SU_D(PerlIO_printf(Perl_debug_log,
+                  "%p: push a fake slot      at scope_ix=%2d  save_ix=%2d\n",
+                   ud,                      PL_scopestack_ix, PL_savestack_ix));
    save_int(&MY_CXT.stack_placeholder);
-  } while (PL_savestack_ix + 3 <= PL_scopestack[PL_scopestack_ix - 1]);
+  } while (PL_savestack_ix + SU_SAVE_DESTRUCTOR_SIZE
+                                        <= PL_scopestack[PL_scopestack_ix - 1]);
  }
-
+ SU_D(PerlIO_printf(Perl_debug_log,
+                  "%p: push first destructor at scope_ix=%2d  save_ix=%2d\n",
+                   ud,                      PL_scopestack_ix, PL_savestack_ix));
  SAVEDESTRUCTOR_X(su_pop, ud);
 
  SU_D({

diff --git a/samples/tag.pl b/samples/tag.pl
index ca017dd8c0b36a1a757de9a1f907ad83f924bf7f..c414c0790b843e1244f62cc882a810504a527d58 100644 (file)
--- a/samples/tag.pl
+++ b/samples/tag.pl
@@ -3,6 +3,8 @@
 use strict;
 use warnings;
 
+use blib;
+
 package Scope;
 
 use Scope::Upper qw/reap localize localize_elem localize_delete :words/;
@@ -53,7 +55,7 @@ package UserLand;
 
   {
    Scope->private;
-   eval { require Cwd };
+   eval { delete $INC{"Cwd.pm"}; require Cwd }; # blib loads Cwd
    print $@;             # prints "Can't locate Cwd.pm in @INC (@INC contains:) at..."
   }
 

diff --git a/t/16-reap-numerous.t b/t/16-reap-numerous.t
new file mode 100644 (file)
index 0000000..d876e07
--- /dev/null
+++ b/t/16-reap-numerous.t
@@ -0,0 +1,29 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+my $n;
+BEGIN { $n = 1000; }
+
+use Test::More tests => $n;
+
+use Scope::Upper qw/reap UP/;
+
+my $count;
+
+sub setup {
+ for my $i (reverse 1 .. $n) {
+  reap {
+   is $count, $i, "$i-th destructor called at the right time";
+   ++$count;
+  } UP UP;
+ }
+}
+
+$count = $n + 1;
+
+{
+ setup;
+ $count = 1;
+}

diff --git a/t/26-localize-numerous.t b/t/26-localize-numerous.t
new file mode 100644 (file)
index 0000000..a33a4e0
--- /dev/null
+++ b/t/26-localize-numerous.t
@@ -0,0 +1,27 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+my $n;
+BEGIN { $n = 1000; }
+
+use Test::More tests => 3;
+
+use Scope::Upper qw/localize UP/;
+
+our $x = 0;
+our $z = $n;
+
+sub setup {
+ for (1 .. $n) {
+  localize *x, *z => UP UP;
+ }
+}
+
+is $x,  0,  '$x is correctly initialized';
+{
+ setup;
+ is $x, $n, '$x is correctly localized';
+}
+is $x,  0,  '$x regained its original value';

diff --git a/t/36-localize_elem-numerous.t b/t/36-localize_elem-numerous.t
new file mode 100644 (file)
index 0000000..95247d8
--- /dev/null
+++ b/t/36-localize_elem-numerous.t
@@ -0,0 +1,26 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+my $n;
+BEGIN { $n = 1000; }
+
+use Test::More tests => 3;
+
+use Scope::Upper qw/localize_elem UP/;
+
+our @A = ((0) x $n);
+
+sub setup {
+ for (reverse 0 .. ($n-1)) {
+  localize_elem '@A', $_ => ($_ + 1) => UP UP;
+ }
+}
+
+is_deeply  \@A, [ (0) x $n ], '@A was correctly initialized';
+{
+ setup;
+ is_deeply \@A, [ 1 .. $n ],  '@A elements are correctly localized';
+}
+is_deeply  \@A, [ (0) x $n ], '@A regained its original elements';

diff --git a/t/46-localize_delete-numerous.t b/t/46-localize_delete-numerous.t
new file mode 100644 (file)
index 0000000..183dadc
--- /dev/null
+++ b/t/46-localize_delete-numerous.t
@@ -0,0 +1,26 @@
+#!perl -T
+
+use strict;
+use warnings;
+
+my $n;
+BEGIN { $n = 1000; }
+
+use Test::More tests => 3;
+
+use Scope::Upper qw/localize_delete UP/;
+
+our @A = (1 .. $n);
+
+sub setup {
+ for (reverse 0 .. ($n-1)) {
+  localize_delete '@A', $_ => UP UP;
+ }
+}
+
+is_deeply  \@A, [ 1 .. $n ], '@A was correctly initialized';
+{
+ setup;
+ is_deeply \@A, [ ],         '@A is empty inside the block';
+}
+is_deeply  \@A, [ 1 .. $n ], '@A regained its elements';