/* 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.
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. */
/*
=for apidoc sv_magicext
-Adds magic to an SV, upgrading it if necessary. Applies the
+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
+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<name> is NULL then namelen bytes are allocated and Zero()-ed),
-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
+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
(This is now used as a subroutine by sv_magic.)
const char* name, I32 namlen)
{
MAGIC* mg;
-
+
if (SvTYPE(sv) < SVt_PVMG) {
(void)SvUPGRADE(sv, SVt_PVMG);
}
mg->mg_ptr = savepvn(name, namlen);
else if (namlen == HEf_SVKEY)
mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
- else
+ else
mg->mg_ptr = (char *) name;
}
mg->mg_virtual = vtable;
-
+
mg_magical(sv);
if (SvGMAGICAL(sv))
SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
void
Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
-{
+{
MAGIC* mg;
MGVTBL *vtable = 0;
}
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
+ /* 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:
vtable = &PL_vtbl_sv;
default:
Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
}
-
+
/* 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;
char *pv2;
STRLEN cur2;
I32 eq = 0;
- char *tpv = Nullch;
if (!sv1) {
pv1 = "";
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;
- }
- }
-
- if (cur1 == cur2)
- eq = memEQ(pv1, pv2, cur1);
+ if (SvUTF8(sv1) == SvUTF8(sv2) || IN_BYTES)
+ eq = (cur1 == cur2) && memEQ(pv1, pv2, cur1);
+ else if (SvUTF8(sv1)) /* do not utf8ize the comparands as a side-effect */
+ eq = !memcmp_byte_utf8(pv2, cur2, pv1, cur1);
+ else
+ eq = !memcmp_byte_utf8(pv1, cur1, pv2, cur2);
- if (tpv != Nullch)
- Safefree(tpv);
-
return eq;
}
{
STRLEN cur1, cur2;
char *pv1, *pv2;
- I32 cmp;
- bool pv1tmp = FALSE;
- bool pv2tmp = FALSE;
+ I32 retval;
if (!sv1) {
pv1 = "";
else
pv2 = SvPV(sv2, cur2);
- /* do not utf8ize the comparands as a side-effect */
- if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
- if (SvUTF8(sv1)) {
- pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
- pv2tmp = TRUE;
- }
- else {
- pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
- pv1tmp = TRUE;
- }
- }
-
if (!cur1) {
- cmp = cur2 ? -1 : 0;
+ return cur2 ? -1 : 0;
} else if (!cur2) {
- cmp = 1;
- } else {
- I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
+ return 1;
+ } else if (SvUTF8(sv1) == SvUTF8(sv2) || IN_BYTES) {
+ retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
if (retval) {
- cmp = retval < 0 ? -1 : 1;
+ return retval < 0 ? -1 : 1;
} else if (cur1 == cur2) {
- cmp = 0;
- } else {
- cmp = cur1 < cur2 ? -1 : 1;
+ return 0;
+ } else {
+ return cur1 < cur2 ? -1 : 1;
}
- }
-
- if (pv1tmp)
- Safefree(pv1);
- if (pv2tmp)
- Safefree(pv2);
+ } else if (SvUTF8(sv1)) /* do not utf8ize the comparands as a side-effect */
+ retval = -memcmp_byte_utf8(pv2, cur2, pv1, cur1);
+ else
+ retval = memcmp_byte_utf8(pv1, cur1, pv2, cur2);
- return cmp;
+ if (retval) /* CURs taken into account already */
+ return retval < 0 ? -1 : 1;
+ return 0;
}
/*
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)) {
return SvPVX(sv);
}
+
projects / p5sagit/p5-mst-13.2.git / blobdiff