In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/ca82605123510c943557b181da9bd0ddd3313665?hp=432d4561c48cd74f3299eddc270a890908a4512e>
- Log ----------------------------------------------------------------- commit ca82605123510c943557b181da9bd0ddd3313665 Author: Father Chrysostomos <[email protected]> Date: Sun Sep 23 23:47:57 2012 -0700 [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. ----------------------------------------------------------------------- Summary of changes: embed.fnc | 2 ++ embed.h | 1 + pp_ctl.c | 10 +++++++--- proto.h | 1 + sv.c | 16 ++++++++++++---- t/op/reset.t | 45 +++++++++++++++++++++++++++++++++++++++++++-- 6 files changed, 66 insertions(+), 9 deletions(-) diff --git a/embed.fnc b/embed.fnc index 8b03b25..8aa3efb 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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>; -- Perl5 Master Repository
