Make utf8::encode respect magic

[perl5.git] / sv.c

diff --git a/sv.c b/sv.c
index 2bf9e8f..906c30e 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -1397,6 +1397,7 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type)
            SvOBJECT_on(io);
            /* Clear the stashcache because a new IO could overrule a package
               name */
+            DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
            hv_clear(PL_stashcache);
 
            SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
@@ -3163,7 +3164,7 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, ST
 
     if (sv == &PL_sv_undef)
        return 0;
-    if (!SvPOK(sv)) {
+    if (!SvPOK_nog(sv)) {
        STRLEN len = 0;
        if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) {
            (void) sv_2pv_flags(sv,&len, flags);
@@ -3882,6 +3883,14 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
            assert(mg);
            Perl_magic_clearisa(aTHX_ NULL, mg);
        }
+        else if (stype == SVt_PVIO) {
+            DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing PL_stashcache\n"));
+            /* It's a cache. It will rebuild itself quite happily.
+               It's a lot of effort to work out exactly which key (or keys)
+               might be invalidated by the creation of the this file handle.
+            */
+            hv_clear(PL_stashcache);
+        }
        break;
     }
     SvREFCNT_dec(dref);
@@ -5906,10 +5915,11 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
     assert(GvGP(gv));
     assert(!CvANON(cv));
     assert(CvGV(cv) == gv);
+    assert(!CvNAMED(cv));
 
     /* will the CV shortly be freed by gp_free() ? */
     if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) {
-       SvANY(cv)->xcv_gv = NULL;
+       SvANY(cv)->xcv_gv_u.xcv_gv = NULL;
        return;
     }
 
@@ -5923,7 +5933,7 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv)
 
     CvANON_on(cv);
     CvCVGV_RC_on(cv);
-    SvANY(cv)->xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
+    SvANY(cv)->xcv_gv_u.xcv_gv = MUTABLE_GV(SvREFCNT_inc(anongv));
 }
 
 
@@ -6046,9 +6056,12 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
                if (   PL_phase != PERL_PHASE_DESTRUCT
                    && (name = HvNAME((HV*)sv)))
                {
-                   if (PL_stashcache)
+                   if (PL_stashcache) {
+                    DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache for '%"SVf"'\n",
+                                     sv));
                        (void)hv_delete(PL_stashcache, name,
                            HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) : HvNAMELEN_get((HV*)sv), G_DISCARD);
+                    }
                    hv_name_set((HV*)sv, NULL, 0, 0);
                }
 
@@ -6459,7 +6472,8 @@ Perl_sv_free2(pTHX_ SV *const sv)
 =for apidoc sv_len
 
 Returns the length of the string in the SV.  Handles magic and type
-coercion.  See also C<SvCUR>, which gives raw access to the xpv_cur slot.
+coercion and sets the UTF8 flag appropriately.  See also C<SvCUR>, which
+gives raw access to the xpv_cur slot.
 
 =cut
 */
@@ -6472,10 +6486,7 @@ Perl_sv_len(pTHX_ register SV *const sv)
     if (!sv)
        return 0;
 
-    if (SvGMAGICAL(sv))
-       len = mg_length(sv);
-    else
-        (void)SvPV_const(sv, len);
+    (void)SvPV_const(sv, len);
     return len;
 }
 
@@ -6503,13 +6514,8 @@ Perl_sv_len_utf8(pTHX_ register SV *const sv)
     if (!sv)
        return 0;
 
-    if (SvGMAGICAL(sv))
-       return mg_length(sv);
-    else
-    {
-       SvGETMAGIC(sv);
-       return sv_len_utf8_nomg(sv);
-    }
+    SvGETMAGIC(sv);
+    return sv_len_utf8_nomg(sv);
 }
 
 STRLEN
@@ -6521,7 +6527,7 @@ Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
 
     PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG;
 
-    if (PL_utf8cache) {
+    if (PL_utf8cache && SvUTF8(sv)) {
            STRLEN ulen;
            MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
 
@@ -6548,7 +6554,7 @@ Perl_sv_len_utf8_nomg(pTHX_ SV * const sv)
            }
            return ulen;
     }
-    return Perl_utf8_length(aTHX_ s, s + len);
+    return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len;
 }
 
 /* Walk forwards to find the byte corresponding to the passed in UTF-8
@@ -6636,7 +6642,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start
     if (!uoffset)
        return 0;
 
-    if (!SvREADONLY(sv)
+    if (!SvREADONLY(sv) && !SvGMAGICAL(sv)
        && PL_utf8cache
        && (*mgp || (SvTYPE(sv) >= SVt_PVMG &&
                     (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) {
@@ -6719,7 +6725,7 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start
        boffset = real_boffset;
     }
 
-    if (PL_utf8cache) {
+    if (PL_utf8cache && !SvGMAGICAL(sv)) {
        if (at_end)
            utf8_mg_len_cache_update(sv, mgp, uoffset);
        else
@@ -8708,11 +8714,12 @@ Perl_newSVsv(pTHX_ register SV *const old)
        Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
        return NULL;
     }
+    /* Do this here, otherwise we leak the new SV if this croaks. */
+    SvGETMAGIC(old);
     new_SV(sv);
-    /* SV_GMAGIC is the default for sv_setv()
-       SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
+    /* SV_NOSTEAL prevents TEMP buffers being, well, stolen, and saves games
        with SvTEMP_off and SvTEMP_on round a call to sv_setsv.  */
-    sv_setsv_flags(sv, old, SV_GMAGIC | SV_NOSTEAL);
+    sv_setsv_flags(sv, old, SV_NOSTEAL);
     return sv;
 }
 
@@ -8728,15 +8735,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;
+    const 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**);
@@ -8761,7 +8775,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] == '-') {
@@ -9108,7 +9123,7 @@ Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp)
     PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE;
 
     sv_pvn_force(sv,lp);
-    sv_utf8_upgrade(sv);
+    sv_utf8_upgrade_nomg(sv);
     *lp = SvCUR(sv);
     return SvPVX(sv);
 }
@@ -11231,7 +11246,6 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param)
     parser->multi_open = proto->multi_open;
     parser->multi_start        = proto->multi_start;
     parser->multi_end  = proto->multi_end;
-    parser->pending_ident = proto->pending_ident;
     parser->preambled  = proto->preambled;
     parser->sublex_info        = proto->sublex_info; /* XXX not quite right */
     parser->linestr    = sv_dup_inc(proto->linestr, param);
@@ -12129,6 +12143,7 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                         daux->xhv_mro_meta = saux->xhv_mro_meta
                             ? mro_meta_dup(saux->xhv_mro_meta, param)
                             : 0;
+                       daux->xhv_super = NULL;
 
                        /* Record stashes for possible cloning in Perl_clone(). */
                        if (HvNAME(sstr))
@@ -12160,9 +12175,13 @@ S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param)
                }
                assert(!CvSLABBED(dstr));
                if (CvDYNFILE(dstr)) CvFILE(dstr) = SAVEPV(CvFILE(dstr));
+               if (CvNAMED(dstr))
+                   SvANY((CV *)dstr)->xcv_gv_u.xcv_hek =
+                       share_hek_hek(CvNAME_HEK((CV *)sstr));
                /* don't dup if copying back - CvGV isn't refcounted, so the
                 * duped GV may never be freed. A bit of a hack! DAPM */
-               SvANY(MUTABLE_CV(dstr))->xcv_gv =
+               else
+                 SvANY(MUTABLE_CV(dstr))->xcv_gv_u.xcv_gv =
                    CvCVGV_RC(dstr)
                    ? gv_dup_inc(CvGV(sstr), param)
                    : (param->flags & CLONEf_JOIN_IN)
@@ -13156,7 +13175,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_e_script                = sv_dup_inc(proto_perl->Ie_script, param);
 
     /* magical thingies */
-    PL_formfeed                = sv_dup(proto_perl->Iformfeed, param);
 
     PL_encoding                = sv_dup(proto_perl->Iencoding, param);