Stop substr($utf8) from calling get-magic twice

By calling get-magic twice, it could cause its string buffer to be
reallocated, resulting in incorrect and random return values.

diff --git a/embed.fnc b/embed.fnc
index 290067c..f547316 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1319,6 +1319,7 @@ Apd       |int    |sv_isa         |NULLOK SV* sv|NN const char *const name
 Apd    |int    |sv_isobject    |NULLOK SV* sv
 Apd    |STRLEN |sv_len         |NULLOK SV *const sv
 Apd    |STRLEN |sv_len_utf8    |NULLOK SV *const sv
+p      |STRLEN |sv_len_utf8_nomg|NN SV *const sv
 Apd    |void   |sv_magic       |NN SV *const sv|NULLOK SV *const obj|const int how \
                                |NULLOK const char *const name|const I32 namlen
 Apd    |MAGIC *|sv_magicext    |NN SV *const sv|NULLOK SV *const obj|const int how \

diff --git a/embed.h b/embed.h
index 8da7d45..ecce321 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1212,6 +1212,7 @@
 #define sv_clean_objs()                Perl_sv_clean_objs(aTHX)
 #define sv_del_backref(a,b)    Perl_sv_del_backref(aTHX_ a,b)
 #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_sethek(a,b)         Perl_sv_sethek(aTHX_ a,b)
 #ifndef PERL_IMPLICIT_CONTEXT

diff --git a/pp.c b/pp.c
index 0c148ba..05a9edf 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -3020,7 +3020,7 @@ PP(pp_substr)
     }
     tmps = SvPV_const(sv, curlen);
     if (DO_UTF8(sv)) {
-        utf8_curlen = sv_len_utf8(sv);
+        utf8_curlen = sv_len_utf8_nomg(sv);
        if (utf8_curlen == curlen)
            utf8_curlen = 0;
        else

diff --git a/proto.h b/proto.h
index 21e6e53..7670835 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -4025,6 +4025,11 @@ PERL_CALLCONV IV Perl_sv_iv(pTHX_ SV* sv)
 
 PERL_CALLCONV STRLEN   Perl_sv_len(pTHX_ SV *const sv);
 PERL_CALLCONV STRLEN   Perl_sv_len_utf8(pTHX_ SV *const sv);
+PERL_CALLCONV STRLEN   Perl_sv_len_utf8_nomg(pTHX_ SV *const sv)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG      \
+       assert(sv)
+
 PERL_CALLCONV void     Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, const char *const name, const I32 namlen)
                        __attribute__nonnull__(pTHX_1);
 #define PERL_ARGS_ASSERT_SV_MAGIC      \

diff --git a/sv.c b/sv.c
index 1a0e121..09128ec 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -6507,10 +6507,21 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv)
        return mg_length(sv);
     else
     {
-       STRLEN len;
-       const U8 *s = (U8*)SvPV_const(sv, len);
+       SvGETMAGIC(sv);
+       return sv_len_utf8_nomg(sv);
+    }
+}
+
+STRLEN
+Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
+{
+    dVAR;
+    STRLEN len;
+    const U8 *s = (U8*)SvPV_nomg_const(sv, len);
 
-       if (PL_utf8cache) {
+    PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
+
+    if (PL_utf8cache) {
            STRLEN ulen;
            MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 
@@ -6536,9 +6547,8 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv)
                utf8_mg_len_cache_update(sv, &mg, ulen);
            }
            return ulen;
-       }
-       return Perl_utf8_length(aTHX_ s, s + len);
     }
+    return Perl_utf8_length(aTHX_ s, s + len);
 }
 
 /* Walk forwards to find the byte corresponding to the passed in UTF-8

diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t
index 26666f2..9cadaf6 100644 (file)
--- a/t/op/tie_fetch_count.t
+++ b/t/op/tie_fetch_count.t
@@ -7,7 +7,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan (tests => 303);
+    plan (tests => 304);
 }
 
 use strict;
@@ -248,6 +248,9 @@ for ([chdir=>''],[chmod=>'0,'],[chown=>'0,0,'],[utime=>'0,0,'],
                             ; check_count 'select $tied_undef, ...';
 }
 
+$var = "\x{100}";
+$dummy  = substr$var,0,1; check_count 'substr $utf8';
+
 {
     local $SIG{__WARN__} = sub {};
     $dummy  =  warn $var    ; check_count 'warn $tied';