diff options
| -rw-r--r-- | embed.fnc | 1 | ||||
| -rw-r--r-- | embed.h | 6 | ||||
| -rw-r--r-- | mg.c | 62 | ||||
| -rw-r--r-- | pod/perlguts.pod | 6 | ||||
| -rw-r--r-- | pod/perlintern.pod | 18 | ||||
| -rw-r--r-- | proto.h | 1 | ||||
| -rw-r--r-- | scope.c | 77 | ||||
| -rwxr-xr-x | t/op/local.t | 3 |
8 files changed, 104 insertions, 70 deletions
@@ -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 @@ -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) @@ -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 df90f9e137..34c64126cc 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 006c66c219..b4b6ed7577 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 @@ -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); @@ -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 28613e7a13..00296d9856 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 |