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
 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
 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
 #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 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)
 #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)
 #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>.
 =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_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_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
 
 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
 
 
 =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
 =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_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);
 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) {
     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;
        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;
        }
            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;
 }
     }
     return sv;
 }
@@ -195,6 +170,7 @@ SV *
 Perl_save_scalar(pTHX_ GV *gv)
 {
     SV **sptr = &GvSV(gv);
 Perl_save_scalar(pTHX_ GV *gv)
 {
     SV **sptr = &GvSV(gv);
+    SvGETMAGIC(*sptr);
     SSCHECK(3);
     SSPUSHPTR(SvREFCNT_inc(gv));
     SSPUSHPTR(SvREFCNT_inc(*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)
 {
 SV*
 Perl_save_svref(pTHX_ SV **sptr)
 {
+    SvGETMAGIC(*sptr);
     SSCHECK(3);
     SSPUSHPTR(sptr);
     SSPUSHPTR(SvREFCNT_inc(*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);
 
     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;
 }
 
     return av;
 }
 
@@ -336,15 +306,8 @@ Perl_save_hash(pTHX_ GV *gv)
 
     GvHV(gv) = Null(HV*);
     hv = GvHVn(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;
 }
 
     return hv;
 }
 
@@ -586,6 +549,7 @@ void
 Perl_save_aelem(pTHX_ const AV *av, I32 idx, SV **sptr)
 {
     SV *sv;
 Perl_save_aelem(pTHX_ const AV *av, I32 idx, SV **sptr)
 {
     SV *sv;
+    SvGETMAGIC(*sptr);
     SSCHECK(4);
     SSPUSHPTR(SvREFCNT_inc(av));
     SSPUSHINT(idx);
     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;
 Perl_save_helem(pTHX_ HV *hv, SV *key, SV **sptr)
 {
     SV *sv;
+    SvGETMAGIC(*sptr);
     SSCHECK(4);
     SSPUSHPTR(SvREFCNT_inc(hv));
     SSPUSHPTR(SvREFCNT_inc(key));
     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)));
            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;
            *(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";
 
 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 } };
 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
 print "ok 78\n";
 
 # The s/// adds 'g' magic to $_, but it should remain non-readonly