X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=799ffab5a33e76bc2c76c45bf23f9aa36c6f7b3a;hb=0dbd57a10c8cc972ad52305885705b0194739bca;hp=7488bd90b9038cf13dd224a858573c9684262670;hpb=f1f8f8925a02a6ca4f9ef21b150b369edc63630d;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 7488bd9..799ffab 100644 --- a/sv.c +++ b/sv.c @@ -1,6 +1,6 @@ /* sv.c * - * Copyright (c) 1991-2001, Larry Wall + * Copyright (c) 1991-2002, Larry Wall * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -1584,6 +1584,9 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) SvREADONLY_off(sv); } New(703, s, newlen, char); + if (SvPVX(sv) && SvCUR(sv)) { + Move(SvPVX(sv), s, SvCUR(sv), char); + } } SvPV_set(sv, s); SvLEN_set(sv, newlen); @@ -3145,6 +3148,45 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } /* +=for apidoc sv_copypv + +Copies a stringified representation of the source SV into the +destination SV. Automatically performs any necessary mg_get and +coercion of numeric values into strings. Guaranteed to preserve +UTF-8 flag even from overloaded objects. Similar in nature to +sv_2pv[_flags] but operates directly on an SV instead of just the +string. Mostly uses sv_2pv_flags to do its work, except when that +would lose the UTF-8'ness of the PV. + +=cut +*/ + +void +Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) +{ + SV *tmpsv = sv_newmortal(); + + if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) { + tmpsv = AMG_CALLun(ssv,string); + if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) { + SvSetSV(dsv,tmpsv); + return; + } + } + { + STRLEN len; + char *s; + s = SvPV(ssv,len); + sv_setpvn(tmpsv,s,len); + if (SvUTF8(ssv)) + SvUTF8_on(tmpsv); + else + SvUTF8_off(tmpsv); + SvSetSV(dsv,tmpsv); + } +} + +/* =for apidoc sv_2pvbyte_nolen Return a pointer to the byte-encoded representation of the SV. @@ -3317,7 +3359,7 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) } if (PL_encoding) - Perl_sv_recode_to_utf8(aTHX_ sv, PL_encoding); + sv_recode_to_utf8(sv, PL_encoding); else { /* Assume Latin-1/EBCDIC */ /* This function could be much more efficient if we * had a FLAG in SVs to signal if there are any hibit @@ -3372,28 +3414,6 @@ Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) if (!utf8_to_bytes(s, &len)) { if (fail_ok) return FALSE; -#ifdef USE_BYTES_DOWNGRADES - else if (IN_BYTES) { - U8 *d = s; - U8 *e = (U8 *) SvEND(sv); - int first = 1; - while (s < e) { - UV ch = utf8n_to_uvchr(s,(e-s),&len,0); - if (first && ch > 255) { - if (PL_op) - Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s", - OP_DESC(PL_op); - else - Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte"); - first = 0; - } - *d++ = ch; - s += len; - } - *d = '\0'; - len = (d - (U8 *) SvPVX(sv)); - } -#endif else { if (PL_op) Perl_croak(aTHX_ "Wide character in %s", @@ -3771,8 +3791,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) GvENAME((GV*)dstr)); } } - cv_ckproto(cv, (GV*)dstr, - SvPOK(sref) ? SvPVX(sref) : Nullch); + if (!intro) + cv_ckproto(cv, (GV*)dstr, + SvPOK(sref) ? SvPVX(sref) : Nullch); } GvCV(dstr) = (CV*)sref; GvCVGEN(dstr) = 0; /* Switch off cacheness. */ @@ -4415,43 +4436,33 @@ Perl_newSV(pTHX_ STRLEN len) } return sv; } - /* -=for apidoc sv_magic +=for apidoc sv_magicext -Adds magic to an SV. First upgrades C to type C if necessary, -then adds a new magic item of type C to the head of the magic list. +Adds magic to an SV, upgrading it if necessary. Applies the +supplied vtable and returns pointer to the magic added. + +Note that sv_magicext will allow things that sv_magic will not. +In particular you can add magic to SvREADONLY SVs and and more than +one instance of the same 'how' + +I C is greater then zero then a savepvn() I of C is stored, +if C is zero then C is stored as-is and - as another special +case - if C<(name && namelen == HEf_SVKEY)> then C is assumed to contain +an C and has its REFCNT incremented -C is assumed to contain an C if C<(name && namelen == HEf_SVKEY)> +(This is now used as a subroutine by sv_magic.) =cut */ - -void -Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) +MAGIC * +Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, + const char* name, I32 namlen) { MAGIC* mg; - if (SvREADONLY(sv)) { - if (PL_curcop != &PL_compiling - && how != PERL_MAGIC_regex_global - && how != PERL_MAGIC_bm - && how != PERL_MAGIC_fm - && how != PERL_MAGIC_sv - ) - { - Perl_croak(aTHX_ PL_no_modify); - } - } - if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { - if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { - if (how == PERL_MAGIC_taint) - mg->mg_len |= 1; - return; - } - } - else { - (void)SvUPGRADE(sv, SVt_PVMG); + if (SvTYPE(sv) < SVt_PVMG) { + (void)SvUPGRADE(sv, SVt_PVMG); } Newz(702,mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); @@ -4478,129 +4489,182 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam mg->mg_type = how; mg->mg_len = namlen; if (name) { - if (namlen >= 0) + if (namlen > 0) mg->mg_ptr = savepvn(name, namlen); else if (namlen == HEf_SVKEY) mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name); + else + mg->mg_ptr = (char *) name; + } + mg->mg_virtual = vtable; + + mg_magical(sv); + if (SvGMAGICAL(sv)) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); + return mg; +} + +/* +=for apidoc sv_magic + +Adds magic to an SV. First upgrades C to type C if necessary, +then adds a new magic item of type C to the head of the magic list. + +=cut +*/ + +void +Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) +{ + MAGIC* mg; + MGVTBL *vtable = 0; + + if (SvREADONLY(sv)) { + if (PL_curcop != &PL_compiling + && how != PERL_MAGIC_regex_global + && how != PERL_MAGIC_bm + && how != PERL_MAGIC_fm + && how != PERL_MAGIC_sv + ) + { + Perl_croak(aTHX_ PL_no_modify); + } + } + if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { + if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { + /* sv_magic() refuses to add a magic of the same 'how' as an + existing one + */ + if (how == PERL_MAGIC_taint) + mg->mg_len |= 1; + return; + } } switch (how) { case PERL_MAGIC_sv: - mg->mg_virtual = &PL_vtbl_sv; + vtable = &PL_vtbl_sv; break; case PERL_MAGIC_overload: - mg->mg_virtual = &PL_vtbl_amagic; + vtable = &PL_vtbl_amagic; break; case PERL_MAGIC_overload_elem: - mg->mg_virtual = &PL_vtbl_amagicelem; + vtable = &PL_vtbl_amagicelem; break; case PERL_MAGIC_overload_table: - mg->mg_virtual = &PL_vtbl_ovrld; + vtable = &PL_vtbl_ovrld; break; case PERL_MAGIC_bm: - mg->mg_virtual = &PL_vtbl_bm; + vtable = &PL_vtbl_bm; break; case PERL_MAGIC_regdata: - mg->mg_virtual = &PL_vtbl_regdata; + vtable = &PL_vtbl_regdata; break; case PERL_MAGIC_regdatum: - mg->mg_virtual = &PL_vtbl_regdatum; + vtable = &PL_vtbl_regdatum; break; case PERL_MAGIC_env: - mg->mg_virtual = &PL_vtbl_env; + vtable = &PL_vtbl_env; break; case PERL_MAGIC_fm: - mg->mg_virtual = &PL_vtbl_fm; + vtable = &PL_vtbl_fm; break; case PERL_MAGIC_envelem: - mg->mg_virtual = &PL_vtbl_envelem; + vtable = &PL_vtbl_envelem; break; case PERL_MAGIC_regex_global: - mg->mg_virtual = &PL_vtbl_mglob; + vtable = &PL_vtbl_mglob; break; case PERL_MAGIC_isa: - mg->mg_virtual = &PL_vtbl_isa; + vtable = &PL_vtbl_isa; break; case PERL_MAGIC_isaelem: - mg->mg_virtual = &PL_vtbl_isaelem; + vtable = &PL_vtbl_isaelem; break; case PERL_MAGIC_nkeys: - mg->mg_virtual = &PL_vtbl_nkeys; + vtable = &PL_vtbl_nkeys; break; case PERL_MAGIC_dbfile: - SvRMAGICAL_on(sv); - mg->mg_virtual = 0; + vtable = 0; break; case PERL_MAGIC_dbline: - mg->mg_virtual = &PL_vtbl_dbline; + vtable = &PL_vtbl_dbline; break; #ifdef USE_5005THREADS case PERL_MAGIC_mutex: - mg->mg_virtual = &PL_vtbl_mutex; + vtable = &PL_vtbl_mutex; break; #endif /* USE_5005THREADS */ #ifdef USE_LOCALE_COLLATE case PERL_MAGIC_collxfrm: - mg->mg_virtual = &PL_vtbl_collxfrm; + vtable = &PL_vtbl_collxfrm; break; #endif /* USE_LOCALE_COLLATE */ case PERL_MAGIC_tied: - mg->mg_virtual = &PL_vtbl_pack; + vtable = &PL_vtbl_pack; break; case PERL_MAGIC_tiedelem: case PERL_MAGIC_tiedscalar: - mg->mg_virtual = &PL_vtbl_packelem; + vtable = &PL_vtbl_packelem; break; case PERL_MAGIC_qr: - mg->mg_virtual = &PL_vtbl_regexp; + vtable = &PL_vtbl_regexp; break; case PERL_MAGIC_sig: - mg->mg_virtual = &PL_vtbl_sig; + vtable = &PL_vtbl_sig; break; case PERL_MAGIC_sigelem: - mg->mg_virtual = &PL_vtbl_sigelem; + vtable = &PL_vtbl_sigelem; break; case PERL_MAGIC_taint: - mg->mg_virtual = &PL_vtbl_taint; - mg->mg_len = 1; + vtable = &PL_vtbl_taint; break; case PERL_MAGIC_uvar: - mg->mg_virtual = &PL_vtbl_uvar; + vtable = &PL_vtbl_uvar; break; case PERL_MAGIC_vec: - mg->mg_virtual = &PL_vtbl_vec; + vtable = &PL_vtbl_vec; break; case PERL_MAGIC_substr: - mg->mg_virtual = &PL_vtbl_substr; + vtable = &PL_vtbl_substr; break; case PERL_MAGIC_defelem: - mg->mg_virtual = &PL_vtbl_defelem; + vtable = &PL_vtbl_defelem; break; case PERL_MAGIC_glob: - mg->mg_virtual = &PL_vtbl_glob; + vtable = &PL_vtbl_glob; break; case PERL_MAGIC_arylen: - mg->mg_virtual = &PL_vtbl_arylen; + vtable = &PL_vtbl_arylen; break; case PERL_MAGIC_pos: - mg->mg_virtual = &PL_vtbl_pos; + vtable = &PL_vtbl_pos; break; case PERL_MAGIC_backref: - mg->mg_virtual = &PL_vtbl_backref; + vtable = &PL_vtbl_backref; break; case PERL_MAGIC_ext: /* Reserved for use by extensions not perl internals. */ /* Useful for attaching extension internal data to perl vars. */ /* Note that multiple extensions may clash if magical scalars */ /* etc holding private data from one are passed to another. */ - SvRMAGICAL_on(sv); break; default: Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); } - mg_magical(sv); - if (SvGMAGICAL(sv)) - SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK); + + /* Rest of work is done else where */ + mg = sv_magicext(sv,obj,how,vtable,name,namlen); + + switch (how) { + case PERL_MAGIC_taint: + mg->mg_len = 1; + break; + case PERL_MAGIC_ext: + case PERL_MAGIC_dbfile: + SvRMAGICAL_on(sv); + break; + } } /* @@ -4626,7 +4690,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) if (vtbl && vtbl->svt_free) CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg); if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len >= 0) + if (mg->mg_len > 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) SvREFCNT_dec((SV*)mg->mg_ptr); @@ -5286,6 +5350,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) STRLEN cur2; I32 eq = 0; char *tpv = Nullch; + SV* svrecode = Nullsv; if (!sv1) { pv1 = ""; @@ -5301,33 +5366,57 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) else pv2 = SvPV(sv2, cur2); - /* do not utf8ize the comparands as a side-effect */ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { - bool is_utf8 = TRUE; - /* UTF-8ness differs */ - - if (SvUTF8(sv1)) { - /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */ - char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8); - if (pv != pv1) - pv1 = tpv = pv; - } - else { - /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */ - char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8); - if (pv != pv2) - pv2 = tpv = pv; - } - if (is_utf8) { - /* Downgrade not possible - cannot be eq */ - return FALSE; - } + /* Differing utf8ness. + * Do not UTF8size the comparands as a side-effect. */ + if (PL_encoding) { + if (SvUTF8(sv1)) { + svrecode = newSVpvn(pv2, cur2); + sv_recode_to_utf8(svrecode, PL_encoding); + pv2 = SvPV(svrecode, cur2); + } + else { + svrecode = newSVpvn(pv1, cur1); + sv_recode_to_utf8(svrecode, PL_encoding); + pv1 = SvPV(svrecode, cur1); + } + /* Now both are in UTF-8. */ + if (cur1 != cur2) + return FALSE; + } + else { + bool is_utf8 = TRUE; + + if (SvUTF8(sv1)) { + /* sv1 is the UTF-8 one, + * if is equal it must be downgrade-able */ + char *pv = (char*)bytes_from_utf8((U8*)pv1, + &cur1, &is_utf8); + if (pv != pv1) + pv1 = tpv = pv; + } + else { + /* sv2 is the UTF-8 one, + * if is equal it must be downgrade-able */ + char *pv = (char *)bytes_from_utf8((U8*)pv2, + &cur2, &is_utf8); + if (pv != pv2) + pv2 = tpv = pv; + } + if (is_utf8) { + /* Downgrade not possible - cannot be eq */ + return FALSE; + } + } } if (cur1 == cur2) eq = memEQ(pv1, pv2, cur1); - if (tpv != Nullch) + if (svrecode) + SvREFCNT_dec(svrecode); + + if (tpv) Safefree(tpv); return eq; @@ -5348,10 +5437,9 @@ I32 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) { STRLEN cur1, cur2; - char *pv1, *pv2; + char *pv1, *pv2, *tpv = Nullch; I32 cmp; - bool pv1tmp = FALSE; - bool pv2tmp = FALSE; + SV *svrecode = Nullsv; if (!sv1) { pv1 = ""; @@ -5360,22 +5448,35 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) else pv1 = SvPV(sv1, cur1); - if (!sv2){ + if (!sv2) { pv2 = ""; cur2 = 0; } else pv2 = SvPV(sv2, cur2); - /* do not utf8ize the comparands as a side-effect */ if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { + /* Differing utf8ness. + * Do not UTF8size the comparands as a side-effect. */ if (SvUTF8(sv1)) { - pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2); - pv2tmp = TRUE; + if (PL_encoding) { + svrecode = newSVpvn(pv2, cur2); + sv_recode_to_utf8(svrecode, PL_encoding); + pv2 = SvPV(svrecode, cur2); + } + else { + pv2 = tpv = (char*)bytes_to_utf8((U8*)pv2, &cur2); + } } else { - pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1); - pv1tmp = TRUE; + if (PL_encoding) { + svrecode = newSVpvn(pv1, cur1); + sv_recode_to_utf8(svrecode, PL_encoding); + pv1 = SvPV(svrecode, cur1); + } + else { + pv1 = tpv = (char*)bytes_to_utf8((U8*)pv1, &cur1); + } } } @@ -5395,10 +5496,11 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) } } - if (pv1tmp) - Safefree(pv1); - if (pv2tmp) - Safefree(pv2); + if (svrecode) + SvREFCNT_dec(svrecode); + + if (tpv) + Safefree(tpv); return cmp; } @@ -8658,7 +8760,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) nmg->mg_len = mg->mg_len; nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len >= 0) { + if (mg->mg_len > 0) { nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len); if (mg->mg_type == PERL_MAGIC_overload_table && AMT_AMAGIC((AMT*)mg->mg_ptr)) @@ -8674,6 +8776,9 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) else if (mg->mg_len == HEf_SVKEY) nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param); } + if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) { + CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param); + } mgprev = nmg; } return mgret; @@ -8894,9 +8999,9 @@ Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param) else if (SvPVX(sstr)) { /* Has something there */ if (SvLEN(sstr)) { - /* Normal PV - clone whole allocated space */ + /* Normal PV - clone whole allocated space */ SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1); - } + } else { /* Special case - not normally malloced for some reason */ if (SvREADONLY(sstr) && SvFAKE(sstr)) { @@ -10450,3 +10555,4 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) return SvPVX(sv); } +