From: Dave Mitchell <davem@fdisolutions.com>
Date: Wed, 22 Jun 2005 21:42:54 +0000 (+0000)
Subject: handle magic in local correctly
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0cbee0a449cc4e11ef8db851c20b026c8f9ff45e;p=p5sagit%2Fp5-mst-13.2.git
handle magic in local correctly
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
---
diff --git a/embed.fnc b/embed.fnc
index 6b515c6..1bf8f08 100644
--- 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
--- a/embed.h
+++ b/embed.h
@@ -460,6 +460,9 @@
#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
@@ -2434,6 +2437,9 @@
#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
--- 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>.
diff --git a/pod/perlguts.pod b/pod/perlguts.pod
index df90f9e..34c6412 100644
--- a/pod/perlguts.pod
+++ b/pod/perlguts.pod
@@ -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
diff --git a/pod/perlintern.pod b/pod/perlintern.pod
index 006c66c..b4b6ed7 100644
--- a/pod/perlintern.pod
+++ b/pod/perlintern.pod
@@ -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
--- 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
--- 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;
diff --git a/t/op/local.t b/t/op/local.t
index 28613e7..00296d9 100755
--- a/t/op/local.t
+++ b/t/op/local.t
@@ -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