/* 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.
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);
}
/*
+=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.
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",
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. */
}
return sv;
}
-
/*
-=for apidoc sv_magic
+=for apidoc sv_magicext
-Adds magic to an SV. First upgrades C<sv> to type C<SVt_PVMG> if necessary,
-then adds a new magic item of type C<how> 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<namelen> is greater then zero then a savepvn() I<copy> of C<name> is stored,
+if C<namelen> is zero then C<name> is stored as-is and - as another special
+case - if C<(name && namelen == HEf_SVKEY)> then C<name> is assumed to contain
+an C<SV*> and has its REFCNT incremented
-C<name> is assumed to contain an C<SV*> 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);
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<sv> to type C<SVt_PVMG> if necessary,
+then adds a new magic item of type C<how> 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;
+ }
}
/*
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);
continue; /* not "break" */
}
+ if (is_utf8 != has_utf8) {
+ if (is_utf8) {
+ if (SvCUR(sv))
+ sv_utf8_upgrade(sv);
+ }
+ else {
+ SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
+ sv_utf8_upgrade(nsv);
+ eptr = SvPVX(nsv);
+ elen = SvCUR(nsv);
+ }
+ SvGROW(sv, SvCUR(sv) + elen + 1);
+ p = SvEND(sv);
+ *p = '\0';
+ }
+
have = esignlen + zeros + elen;
need = (have > width ? have : width);
gap = need - have;
*p++ = '0';
}
if (elen) {
- if (is_utf8 != has_utf8) {
- if (is_utf8) {
- if (SvCUR(sv)) {
- sv_utf8_upgrade(sv);
- p = SvEND(sv);
- }
- }
- else {
- SV *nsv = sv_2mortal(newSVpvn(eptr, elen));
- sv_utf8_upgrade(nsv);
- eptr = SvPVX(nsv);
- elen = SvCUR(nsv);
- }
- }
Copy(eptr, p, elen, char);
p += elen;
}
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))
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;
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)) {
/* see if it is part of the interpreter structure */
if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl));
- else
+ else {
ret = v;
+ }
return ret;
}
ptr = POPPTR(ss,ix);
TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
break;
+ case SAVEt_SHARED_PVREF: /* char* in shared space */
+ c = (char*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = savesharedpv(c);
+ ptr = POPPTR(ss,ix);
+ TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
+ break;
case SAVEt_GENERIC_SVREF: /* generic sv */
case SAVEt_SVREF: /* scalar reference */
sv = (SV*)POPPTR(ss,ix);
SvNVX(&PL_sv_yes) = 1;
ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
- /* create shared string table */
+ /* create (a non-shared!) shared string table */
PL_strtab = newHV();
HvSHAREKEYS_off(PL_strtab);
hv_ksplit(PL_strtab, 512);
ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
- PL_compiling = proto_perl->Icompiling;
- PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
- PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
+ PL_compiling = proto_perl->Icompiling;
+
+ /* These two PVs will be free'd special way so must set them same way op.c does */
+ PL_compiling.cop_stashpv = savesharedpv(PL_compiling.cop_stashpv);
+ ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_stashpv, PL_compiling.cop_stashpv);
+
+ PL_compiling.cop_file = savesharedpv(PL_compiling.cop_file);
+ ptr_table_store(PL_ptr_table, proto_perl->Icompiling.cop_file, PL_compiling.cop_file);
+
ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
if (!specialWARN(PL_compiling.cop_warnings))
PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings, param);
return SvPVX(sv);
}
+
https://perl5.git.perl.org / perl5.git / blobdiff