Reset the iterator when an array is cleared

This fixes RT #75596.

diff --git a/embed.fnc b/embed.fnc
index 1f62b9d..568c980 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -754,6 +754,7 @@ p   |int    |magic_regdatum_get|NN SV* sv|NN MAGIC* mg
 pr     |int    |magic_regdatum_set|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_set      |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setarylen|NN SV* sv|NN MAGIC* mg
+p      |int    |magic_cleararylen_p|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_freearylen_p|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setdbline|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_setdefelem|NN SV* sv|NN MAGIC* mg

diff --git a/embed.h b/embed.h
index 260bee9..efc19d8 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1098,6 +1098,7 @@
 #define list(a)                        Perl_list(aTHX_ a)
 #define localize(a,b)          Perl_localize(aTHX_ a,b)
 #define magic_clear_all_env(a,b)       Perl_magic_clear_all_env(aTHX_ a,b)
+#define magic_cleararylen_p(a,b)       Perl_magic_cleararylen_p(aTHX_ a,b)
 #define magic_clearenv(a,b)    Perl_magic_clearenv(aTHX_ a,b)
 #define magic_clearhint(a,b)   Perl_magic_clearhint(aTHX_ a,b)
 #define magic_clearhints(a,b)  Perl_magic_clearhints(aTHX_ a,b)

diff --git a/mg.c b/mg.c
index 4424bfe..4d6df84 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -2043,6 +2043,21 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
 }
 
 int
+Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
+{
+    dVAR;
+
+    PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
+    PERL_UNUSED_ARG(sv);
+
+    /* Reset the iterator when the array is cleared */
+    if (mg->mg_ptr)
+        *((IV *) mg->mg_ptr) = 0;
+
+    return 0;
+}
+
+int
 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;

diff --git a/mg_vtable.h b/mg_vtable.h
index d2379f2..3c73c2b 100644 (file)
--- a/mg_vtable.h
+++ b/mg_vtable.h
@@ -147,7 +147,7 @@ EXTCONST char *PL_magic_vtable_names[magic_vtable_max];
 #ifdef DOINIT
 EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
   { (int (*)(pTHX_ SV *, MAGIC *))Perl_magic_getarylen, Perl_magic_setarylen, 0, 0, 0, 0, 0, 0 },
-  { 0, 0, 0, 0, Perl_magic_freearylen_p, 0, 0, 0 },
+  { 0, 0, 0, Perl_magic_cleararylen_p, Perl_magic_freearylen_p, 0, 0, 0 },
   { 0, 0, 0, 0, Perl_magic_killbackrefs, 0, 0, 0 },
   { 0, 0, 0, 0, 0, Perl_magic_copycallchecker, 0, 0 },
 #ifdef USE_LOCALE_COLLATE

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 3d1733c..a3ee589 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -342,6 +342,16 @@ C<do FILE> now always either sets or clears C<$@>, even when the file can't be
 read. This ensures that testing C<$@> first (as recommended by the
 documentation) always returns the correct result.
 
+=item *
+
+The array iterator used for the C<each @array> construct is now correctly
+reset when C<@array> is cleared (RT #75596). This happens for example when the
+array is globally assigned to, as in C<@array = (...)>, but not when its
+B<values> are assigned to. In terms of the XS API, it means that C<av_clear()>
+will now reset the iterator.
+
+This mirrors the behaviour of the hash iterator when the hash is cleared.
+
 =back
 
 =head1 Known Problems

diff --git a/proto.h b/proto.h
index 3188170..6e8ae37 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2026,6 +2026,12 @@ PERL_CALLCONV int        Perl_magic_clear_all_env(pTHX_ SV* sv, MAGIC* mg)
 #define PERL_ARGS_ASSERT_MAGIC_CLEAR_ALL_ENV   \
        assert(sv); assert(mg)
 
+PERL_CALLCONV int      Perl_magic_cleararylen_p(pTHX_ SV* sv, MAGIC* mg)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P   \
+       assert(sv); assert(mg)
+
 PERL_CALLCONV int      Perl_magic_clearenv(pTHX_ SV* sv, MAGIC* mg)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);

diff --git a/regen/mg_vtable.pl b/regen/mg_vtable.pl
index 5d0710f..bfc13e2 100644 (file)
--- a/regen/mg_vtable.pl
+++ b/regen/mg_vtable.pl
@@ -121,7 +121,7 @@ my %sig =
      'isa' => {set => 'setisa', clear => 'clearisa'},
      'isaelem' => {set => 'setisa'},
      'arylen' => {get => 'getarylen', set => 'setarylen', const => 1},
-     'arylen_p' => {free => 'freearylen_p'},
+     'arylen_p' => {clear => 'cleararylen_p', free => 'freearylen_p'},
      'mglob' => {set => 'setmglob'},
      'nkeys' => {get => 'getnkeys', set => 'setnkeys'},
      'taint' => {get => 'gettaint', set => 'settaint'},

diff --git a/t/op/each_array.t b/t/op/each_array.t
index 95710e2..0c1e080 100644 (file)
--- a/t/op/each_array.t
+++ b/t/op/each_array.t
@@ -9,7 +9,7 @@ use strict;
 use warnings;
 use vars qw(@array @r $k $v $c);
 
-plan tests => 57;
+plan tests => 63;
 
 @array = qw(crunch zam bloop);
 
@@ -137,3 +137,31 @@ for (; $k = each(@array) ;) {
     is ($k, $v);
     $v++;
 }
+
+# Reset the iterator when the array is cleared [RT #75596]
+{
+    my @a = 'a' .. 'c';
+    my ($i, $v) = each @a;
+    is ("$i-$v", '0-a');
+    @a = 'A' .. 'C';
+    ($i, $v) = each @a;
+    is ("$i-$v", '0-A');
+}
+
+# Check that the iterator is reset when localization ends
+{
+    @array = 'a' .. 'c';
+    my ($i, $v) = each @array;
+    is ("$i-$v", '0-a');
+    {
+        local @array = 'A' .. 'C';
+        my ($i, $v) = each @array;
+        is ("$i-$v", '0-A');
+        ($i, $v) = each @array;
+        is ("$i-$v", '1-B');
+    }
+    ($i, $v) = each @array;
+    is ("$i-$v", '1-b');
+    # Explicit reset
+    while (each @array) { }
+}