handle magic in local correctly

[perl5.git] / mg.c

diff --git a/mg.c b/mg.c
index b2b0620..3669619 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -381,6 +381,68 @@ Perl_mg_copy(pTHX_ SV *sv, SV *nsv, const char *key, I32 klen)
 }
 
 /*
+=for apidoc mg_localize
+
+Copy some of the magic from an existing SV to new localized version of
+that SV. Container magic (eg %ENV, $1, tie) gets copied, value magic
+doesn't (eg taint, pos).
+
+=cut
+*/
+
+void
+Perl_mg_localize(pTHX_ SV *sv, SV *nsv)
+{
+    MAGIC *mg;
+    for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
+       const MGVTBL* const vtbl = mg->mg_virtual;
+       switch (mg->mg_type) {
+       /* value magic types: don't copy */
+       case PERL_MAGIC_bm:
+       case PERL_MAGIC_fm:
+       case PERL_MAGIC_regex_global:
+       case PERL_MAGIC_nkeys:
+#ifdef USE_LOCALE_COLLATE
+       case PERL_MAGIC_collxfrm:
+#endif
+       case PERL_MAGIC_qr:
+       case PERL_MAGIC_taint:
+       case PERL_MAGIC_vec:
+       case PERL_MAGIC_vstring:
+       case PERL_MAGIC_utf8:
+       case PERL_MAGIC_substr:
+       case PERL_MAGIC_defelem:
+       case PERL_MAGIC_arylen:
+       case PERL_MAGIC_pos:
+       case PERL_MAGIC_backref:
+       case PERL_MAGIC_arylen_p:
+       case PERL_MAGIC_rhash:
+       case PERL_MAGIC_symtab:
+           continue;
+       }
+               
+       if ((mg->mg_flags & MGf_COPY) && vtbl->svt_copy) {
+           /* XXX calling the copy method is probably not correct. DAPM */
+           (void)CALL_FPTR(vtbl->svt_copy)(aTHX_ sv, mg, nsv,
+                                   mg->mg_ptr, mg->mg_len);
+       }
+       else {
+           sv_magicext(nsv, mg->mg_obj, mg->mg_type, vtbl,
+                           mg->mg_ptr, mg->mg_len);
+       }
+       /* container types should remain read-only across localization */
+       SvFLAGS(nsv) |= SvREADONLY(sv);
+    }
+
+    if (SvTYPE(nsv) >= SVt_PVMG && SvMAGIC(nsv)) {
+       SvFLAGS(nsv) |= SvMAGICAL(sv);
+       PL_localizing = 1;
+       SvSETMAGIC(nsv);
+       PL_localizing = 0;
+    }      
+}
+
+/*
 =for apidoc mg_free
 
 Free any magic storage used by the SV.  See C<sv_magic>.
@@ -563,6 +625,13 @@ Perl_magic_len(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+#define SvRTRIM(sv) STMT_START { \
+    STRLEN len = SvCUR(sv); \
+    while (len > 0 && isSPACE(SvPVX(sv)[len-1])) \
+       --len; \
+    SvCUR_set(sv, len); \
+} STMT_END
+
 int
 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 {
@@ -648,6 +717,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 #endif
 #endif
 #endif
+            SvRTRIM(sv);
             SvNOK_on(sv);      /* what a wonderful hack! */
         }
         else if (strEQ(mg->mg_ptr+1, "NCODING"))
@@ -879,9 +949,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        if (PL_ors_sv)
            sv_copypv(sv, PL_ors_sv);
        break;
-    case '#':
-       sv_setpv(sv,PL_ofmt);
-       break;
     case '!':
 #ifdef VMS
        sv_setnv(sv, (NV)((errno == EVMSERR) ? vaxc$errno : errno));
@@ -899,6 +966,7 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
        errno = saveerrno;
        }
 #endif
+       SvRTRIM(sv);
        SvNOK_on(sv);   /* what a wonderful hack! */
        break;
     case '<':
@@ -1673,9 +1741,10 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
 int
 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
 {
+    PERL_UNUSED_ARG(sv);
     /* during global destruction, mg_obj may already have been freed */
     if (PL_in_clean_all)
-       return;
+       return 0;
 
     mg = mg_find (mg->mg_obj, PERL_MAGIC_arylen);
 
@@ -2293,11 +2362,6 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
            PL_ofs_sv = Nullsv;
        }
        break;
-    case '#':
-       if (PL_ofmt)
-           Safefree(PL_ofmt);
-       PL_ofmt = savesvpv(sv);
-       break;
     case '[':
        PL_compiling.cop_arybase = SvIOK(sv) ? SvIVX(sv) : sv_2iv(sv);
        break;