This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
handle magic in local correctly
authorDave Mitchell <davem@fdisolutions.com>
Wed, 22 Jun 2005 21:42:54 +0000 (21:42 +0000)
committerDave Mitchell <davem@fdisolutions.com>
Wed, 22 Jun 2005 21:42:54 +0000 (21:42 +0000)
the local SV now gets a copy of any container magic, and no value
magic; in the past the whole magic chain was either shared or
moved

p4raw-id: //depot/perl@24942

embed.fnc
embed.h
mg.c
pod/perlguts.pod
pod/perlintern.pod
proto.h
scope.c
t/op/local.t

index 6b515c6..1bf8f08 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -445,6 +445,7 @@ p   |void   |qerror         |SV* err
 Apd     |void   |sortsv         |SV ** array|size_t num_elts|SVCOMPARE_t cmp
 Apd    |int    |mg_clear       |SV* sv
 Apd    |int    |mg_copy        |SV* sv|SV* nsv|const char* key|I32 klen
+pd     |void   |mg_localize    |SV* sv|SV* nsv
 Apd    |MAGIC* |mg_find        |const SV* sv|int type
 Apd    |int    |mg_free        |SV* sv
 Apd    |int    |mg_get         |SV* sv
diff --git a/embed.h b/embed.h
index 94d7e50..95b2dfb 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define sortsv                 Perl_sortsv
 #define mg_clear               Perl_mg_clear
 #define mg_copy                        Perl_mg_copy
+#ifdef PERL_CORE
+#define mg_localize            Perl_mg_localize
+#endif
 #define mg_find                        Perl_mg_find
 #define mg_free                        Perl_mg_free
 #define mg_get                 Perl_mg_get
 #define sortsv(a,b,c)          Perl_sortsv(aTHX_ a,b,c)
 #define mg_clear(a)            Perl_mg_clear(aTHX_ a)
 #define mg_copy(a,b,c,d)       Perl_mg_copy(aTHX_ a,b,c,d)
+#ifdef PERL_CORE
+#define mg_localize(a,b)       Perl_mg_localize(aTHX_ a,b)
+#endif
 #define mg_find(a,b)           Perl_mg_find(aTHX_ a,b)
 #define mg_free(a)             Perl_mg_free(aTHX_ a)
 #define mg_get(a)              Perl_mg_get(aTHX_ a)
diff --git a/mg.c b/mg.c
index bd5acdf..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>.
index df90f9e..34c6412 100644 (file)
@@ -1046,8 +1046,12 @@ The current kinds of Magic Virtual Tables are:
     *  PERL_MAGIC_glob           vtbl_glob      GV (typeglob)
     #  PERL_MAGIC_arylen         vtbl_arylen    Array length ($#ary)
     .  PERL_MAGIC_pos            vtbl_pos       pos() lvalue
-    <  PERL_MAGIC_backref        vtbl_backref   ???
+    <  PERL_MAGIC_backref        vtbl_backref   back pointer to a weak ref 
     ~  PERL_MAGIC_ext            (none)         Available for use by extensions
+    :  PERL_MAGIC_symtab        (none)         hash used as symbol table
+    %  PERL_MAGIC_rhash                 (none)         hash used as restricted hash
+    @  PERL_MAGIC_arylen_p      vtbl_arylen_p  pointer to $#a from @a
+
 
 When an uppercase and lowercase letter both exist in the table, then the
 uppercase letter is typically used to represent some kind of composite type
index 006c66c..b4b6ed7 100644 (file)
@@ -450,6 +450,24 @@ Found in file doio.c
 
 =back
 
+=head1 Magical Functions
+
+=over 8
+
+=item 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).
+
+       void    mg_localize(SV* sv, SV* nsv)
+
+=for hackers
+Found in file mg.c
+
+
+=back
+
 =head1 Pad Data Structures
 
 =over 8
diff --git a/proto.h b/proto.h
index 473b804..22f84e7 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -828,6 +828,7 @@ PERL_CALLCONV void  Perl_qerror(pTHX_ SV* err);
 PERL_CALLCONV void     Perl_sortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t cmp);
 PERL_CALLCONV int      Perl_mg_clear(pTHX_ SV* sv);
 PERL_CALLCONV int      Perl_mg_copy(pTHX_ SV* sv, SV* nsv, const char* key, I32 klen);
+PERL_CALLCONV void     Perl_mg_localize(pTHX_ SV* sv, SV* nsv);
 PERL_CALLCONV MAGIC*   Perl_mg_find(pTHX_ const SV* sv, int type);
 PERL_CALLCONV int      Perl_mg_free(pTHX_ SV* sv);
 PERL_CALLCONV int      Perl_mg_get(pTHX_ SV* sv);
diff --git a/scope.c b/scope.c
index 1602af6..7e2b129 100644 (file)
--- a/scope.c
+++ b/scope.c
@@ -155,38 +155,13 @@ S_save_scalar_at(pTHX_ SV **sptr)
     register SV * const sv = *sptr = NEWSV(0,0);
 
     if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
-       MAGIC *mg;
-       sv_upgrade(sv, SvTYPE(osv));
        if (SvGMAGICAL(osv)) {
            const bool oldtainted = PL_tainted;
-           mg_get(osv);                /* note, can croak! */
-           if (PL_tainting && PL_tainted &&
-                       (mg = mg_find(osv, PERL_MAGIC_taint))) {
-               SAVESPTR(mg->mg_obj);
-               mg->mg_obj = osv;
-           }
            SvFLAGS(osv) |= (SvFLAGS(osv) &
               (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
            PL_tainted = oldtainted;
        }
-       SvMAGIC_set(sv, SvMAGIC(osv));
-       /* if it's a special scalar or if it has no 'set' magic,
-        * propagate the SvREADONLY flag. --rgs 20030922 */
-       for (mg = SvMAGIC(sv); mg; mg = mg->mg_moremagic) {
-           if (mg->mg_type == '\0'
-                   || !(mg->mg_virtual && mg->mg_virtual->svt_set))
-           {
-               SvFLAGS(sv) |= SvREADONLY(osv);
-               break;
-           }
-       }
-       SvFLAGS(sv) |= SvMAGICAL(osv);
-       /* XXX SvMAGIC() is *shared* between osv and sv.  This can
-        * lead to coredumps when both SVs are destroyed without one
-        * of their SvMAGIC() slots being NULLed. */
-       PL_localizing = 1;
-       SvSETMAGIC(sv);
-       PL_localizing = 0;
+       mg_localize(osv, sv);
     }
     return sv;
 }
@@ -195,6 +170,7 @@ SV *
 Perl_save_scalar(pTHX_ GV *gv)
 {
     SV **sptr = &GvSV(gv);
+    SvGETMAGIC(*sptr);
     SSCHECK(3);
     SSPUSHPTR(SvREFCNT_inc(gv));
     SSPUSHPTR(SvREFCNT_inc(*sptr));
@@ -205,6 +181,7 @@ Perl_save_scalar(pTHX_ GV *gv)
 SV*
 Perl_save_svref(pTHX_ SV **sptr)
 {
+    SvGETMAGIC(*sptr);
     SSCHECK(3);
     SSPUSHPTR(sptr);
     SSPUSHPTR(SvREFCNT_inc(*sptr));
@@ -312,15 +289,8 @@ Perl_save_ary(pTHX_ GV *gv)
 
     GvAV(gv) = Null(AV*);
     av = GvAVn(gv);
-    if (SvMAGIC(oav)) {
-       SvMAGIC_set(av, SvMAGIC(oav));
-       SvFLAGS((SV*)av) |= SvMAGICAL(oav);
-       SvMAGICAL_off(oav);
-       SvMAGIC_set(oav, NULL);
-       PL_localizing = 1;
-       SvSETMAGIC((SV*)av);
-       PL_localizing = 0;
-    }
+    if (SvMAGIC(oav))
+       mg_localize((SV*)oav, (SV*)av);
     return av;
 }
 
@@ -336,15 +306,8 @@ Perl_save_hash(pTHX_ GV *gv)
 
     GvHV(gv) = Null(HV*);
     hv = GvHVn(gv);
-    if (SvMAGIC(ohv)) {
-       SvMAGIC_set(hv, SvMAGIC(ohv));
-       SvFLAGS((SV*)hv) |= SvMAGICAL(ohv);
-       SvMAGICAL_off(ohv);
-       SvMAGIC_set(ohv, NULL);
-       PL_localizing = 1;
-       SvSETMAGIC((SV*)hv);
-       PL_localizing = 0;
-    }
+    if (SvMAGIC(ohv))
+       mg_localize((SV*)ohv, (SV*)hv);
     return hv;
 }
 
@@ -586,6 +549,7 @@ void
 Perl_save_aelem(pTHX_ const AV *av, I32 idx, SV **sptr)
 {
     SV *sv;
+    SvGETMAGIC(*sptr);
     SSCHECK(4);
     SSPUSHPTR(SvREFCNT_inc(av));
     SSPUSHINT(idx);
@@ -608,6 +572,7 @@ void
 Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
 {
     SV *sv;
+    SvGETMAGIC(*sptr);
     SSCHECK(4);
     SSPUSHPTR(SvREFCNT_inc(hv));
     SSPUSHPTR(SvREFCNT_inc(key));
@@ -715,30 +680,6 @@ Perl_leave_scope(pTHX_ I32 base)
            DEBUG_S(PerlIO_printf(Perl_debug_log,
                                  "restore svref: %p %p:%s -> %p:%s\n",
                                  ptr, sv, SvPEEK(sv), value, SvPEEK(value)));
-           if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
-               SvTYPE(sv) != SVt_PVGV)
-           {
-               SvUPGRADE(value, SvTYPE(sv));
-               SvMAGIC_set(value, SvMAGIC(sv));
-               SvFLAGS(value) |= SvMAGICAL(sv);
-               SvMAGICAL_off(sv);
-               SvMAGIC_set(sv, 0);
-           }
-           /* XXX This branch is pretty bogus.  This code irretrievably
-            * clears(!) the magic on the SV (either to avoid further
-            * croaking that might ensue when the SvSETMAGIC() below is
-            * called, or to avoid two different SVs pointing at the same
-            * SvMAGIC()).  This needs a total rethink.  --GSAR */
-           else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) &&
-                    SvTYPE(value) != SVt_PVGV)
-           {
-               SvFLAGS(value) |= (SvFLAGS(value) &
-                                 (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
-               SvMAGICAL_off(value);
-               /* XXX this is a leak when we get here because the
-                * mg_get() in save_scalar_at() croaked */
-               SvMAGIC_set(value, NULL);
-           }
            *(SV**)ptr = value;
            SvREFCNT_dec(sv);
            PL_localizing = 2;
index 28613e7..00296d9 100755 (executable)
@@ -268,8 +268,9 @@ eval { for ($1) { local $_ = 1 } };
 print "not " if $@ !~ /Modification of a read-only value attempted/;
 print "ok 77\n";
 
+# make sure $1 is still read-only
 eval { for ($1) { local $_ = 1 } };
-print "not " if $@;
+print "not " if $@ !~ /Modification of a read-only value attempted/;
 print "ok 78\n";
 
 # The s/// adds 'g' magic to $_, but it should remain non-readonly