[perl #97958] Make reset "" match its docs

According to the documentation, reset() with no argument resets pat-
terns.  But reset "" and reset "\0foo" were also resetting patterns.
While I was at it, I fixed embedded nulls, too, though it’s not likely
anyone is using this.  I could not fix the bug within the existing API
for sv_reset, so I created a new function and left the old one with
the old behaviour.  Call me pear-annoyed.

diff --git a/embed.fnc b/embed.fnc
index 8b03b25..8aa3efb 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1334,6 +1334,8 @@ pd        |SV*    |sv_ref |NULLOK SV *dst|NN const SV *const sv|const int ob
 Apd    |void   |sv_replace     |NN SV *const sv|NN SV *const nsv
 Apd    |void   |sv_report_used
 Apd    |void   |sv_reset       |NN const char* s|NULLOK HV *const stash
+p      |void   |sv_resetpvn    |NULLOK const char* s|STRLEN len \
+                               |NULLOK HV *const stash
 Afpd   |void   |sv_setpvf      |NN SV *const sv|NN const char *const pat|...
 Apd    |void   |sv_vsetpvf     |NN SV *const sv|NN const char *const pat|NULLOK va_list *const args
 Apd    |void   |sv_setiv       |NN SV *const sv|const IV num

diff --git a/embed.h b/embed.h
index 79e10a8..72501d0 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1204,6 +1204,7 @@
 #define sv_free_arenas()       Perl_sv_free_arenas(aTHX)
 #define sv_len_utf8_nomg(a)    Perl_sv_len_utf8_nomg(aTHX_ a)
 #define sv_ref(a,b,c)          Perl_sv_ref(aTHX_ a,b,c)
+#define sv_resetpvn(a,b,c)     Perl_sv_resetpvn(aTHX_ a,b,c)
 #define sv_sethek(a,b)         Perl_sv_sethek(aTHX_ a,b)
 #ifndef PERL_IMPLICIT_CONTEXT
 #define tied_method            Perl_tied_method

diff --git a/pp_ctl.c b/pp_ctl.c
index e857ad4..b26e557 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1933,9 +1933,13 @@ PP(pp_reset)
 {
     dVAR;
     dSP;
-    const char * const tmps =
-       (MAXARG < 1 || (!TOPs && !POPs)) ? (const char *)"" : POPpconstx;
-    sv_reset(tmps, CopSTASH(PL_curcop));
+    const char * tmps;
+    STRLEN len = 0;
+    if (MAXARG < 1 || (!TOPs && !POPs))
+       tmps = NULL, len = 0;
+    else
+       tmps = SvPVx_const(POPs, len);
+    sv_resetpvn(tmps, len, CopSTASH(PL_curcop));
     PUSHs(&PL_sv_yes);
     RETURN;
 }

diff --git a/proto.h b/proto.h
index 94ad613..f2c9d24 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4124,6 +4124,7 @@ PERL_CALLCONV void        Perl_sv_reset(pTHX_ const char* s, HV *const stash)
 #define PERL_ARGS_ASSERT_SV_RESET      \
        assert(s)
 
+PERL_CALLCONV void     Perl_sv_resetpvn(pTHX_ const char* s, STRLEN len, HV *const stash);
 PERL_CALLCONV SV*      Perl_sv_rvweaken(pTHX_ SV *const sv)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SV_RVWEAKEN   \

diff --git a/sv.c b/sv.c
index 8ba2116..6f65062 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -8730,15 +8730,22 @@ Note that the perl-level function is vaguely deprecated.
 void
 Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
 {
+    PERL_ARGS_ASSERT_SV_RESET;
+
+    sv_resetpvn(*s ? s : NULL, strlen(s), stash);
+}
+
+void
+Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash)
+{
     dVAR;
     char todo[PERL_UCHAR_MAX+1];
-
-    PERL_ARGS_ASSERT_SV_RESET;
+    char *send;
 
     if (!stash)
        return;
 
-    if (!*s) {         /* reset ?? searches */
+    if (!s) {          /* reset ?? searches */
        MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab);
        if (mg) {
            const U32 count = mg->mg_len / sizeof(PMOP**);
@@ -8763,7 +8770,8 @@ Perl_sv_reset(pTHX_ register const char *s, HV *const stash)
        return;
 
     Zero(todo, 256, char);
-    while (*s) {
+    send = s + len;
+    while (s < send) {
        I32 max;
        I32 i = (unsigned char)*s;
        if (s[1] == '-') {

diff --git a/t/op/reset.t b/t/op/reset.t
index 3094979..f9ebeee 100644 (file)
--- a/t/op/reset.t
+++ b/t/op/reset.t
@@ -7,8 +7,7 @@ BEGIN {
 }
 use strict;
 
-# Currently only testing the reset of patterns.
-plan tests => 24;
+plan tests => 29;
 
 package aiieee;
 
@@ -62,6 +61,48 @@ CLINK::reset_ZZIP();
 is(CLINK::ZZIP("ZZIP"), 1, "match matches after reset");
 is(CLINK::ZZIP(""), 0, "mismatch doesn't match");
 
+sub match_foo{
+    "foo" =~ m?foo?;
+}
+match_foo();
+reset "";
+ok !match_foo(), 'reset "" leaves patterns alone [perl #97958]';
+
+$scratch::a = "foo";
+$scratch::a2 = "bar";
+$scratch::b   = "baz";
+package scratch { reset "a" }
+is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u'),
+   "u-u-baz",
+   'reset "char"';
+
+$scratch::a = "foo";
+$scratch::a2 = "bar";
+$scratch::b   = "baz";
+$scratch::c    = "sea";
+package scratch { reset "bc" }
+is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u',
+             $scratch::c//'u'),
+   "foo-bar-u-u",
+   'reset "chars"';
+
+$scratch::a = "foo";
+$scratch::a2 = "bar";
+$scratch::b   = "baz";
+$scratch::c    = "sea";
+package scratch { reset "a-b" }
+is join("-", $scratch::a//'u', $scratch::a2//'u', $scratch::b//'u',
+             $scratch::c//'u'),
+   "u-u-u-sea",
+   'reset "range"';
+
+{ no strict; ${"scratch::\0foo"} = "bar" }
+$scratch::a = "foo";
+package scratch { reset "\0a" }
+is join("-", $scratch::a//'u', do { no strict; ${"scratch::\0foo"} }//'u'),
+   "u-u",
+   'reset "\0char"';
+
 
 undef $/;
 my $prog = <DATA>;