/* 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.
}
if (!ok) {
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL,
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Attempt to free non-arena SV: 0x%"UVxf,
PTR2UV(p));
return;
/*
+=head1 SV Manipulation Functions
+
=for apidoc sv_add_arena
Given a chunk of memory, link it to the head of the list of arenas,
return visited;
}
+#ifdef DEBUGGING
+
/* called by sv_report_used() for each live SV */
static void
sv_dump(sv);
}
}
+#endif
/*
=for apidoc sv_report_used
void
Perl_sv_report_used(pTHX)
{
+#ifdef DEBUGGING
visit(do_report_used);
+#endif
}
/* called by sv_clean_objs() for each live SV */
Perl_report_uninit(pTHX)
{
if (PL_op)
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit,
" in ", OP_DESC(PL_op));
else
- Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
+ Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, "", "");
}
/* grab a new IV body from the free list, allocating more if necessary */
bool
Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
{
- char* pv;
- U32 cur;
- U32 len;
- IV iv;
- NV nv;
- MAGIC* magic;
- HV* stash;
+ char* pv = NULL;
+ U32 cur = 0;
+ U32 len = 0;
+ IV iv = 0;
+ NV nv = 0.0;
+ MAGIC* magic = NULL;
+ HV* stash = Nullhv;
if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
sv_force_normal(sv);
SvPVX(sv) = 0;
HvFILL(sv) = 0;
HvMAX(sv) = 0;
- HvKEYS(sv) = 0;
- SvNVX(sv) = 0.0;
+ HvTOTALKEYS(sv) = 0;
+ HvPLACEHOLDERS(sv) = 0;
SvMAGIC(sv) = magic;
SvSTASH(sv) = stash;
HvRITER(sv) = 0;
{
register char *s;
+
+
#ifdef HAS_64K_LIMIT
if (newlen >= 0x10000) {
PerlIO_printf(Perl_debug_log,
}
else
s = SvPVX(sv);
+
if (newlen > SvLEN(sv)) { /* need more room? */
if (SvLEN(sv) && s) {
#if defined(MYMALLOC) && !defined(LEAKTEST)
SvREADONLY_off(sv);
}
New(703, s, newlen, char);
+ if (SvPVX(sv) && SvCUR(sv)) {
+ Move(SvPVX(sv), s, (newlen < SvCUR(sv)) ? newlen : SvCUR(sv), char);
+ }
}
SvPV_set(sv, s);
SvLEN_set(sv, newlen);
char *limit = tmpbuf + sizeof(tmpbuf) - 8;
/* each *s can expand to 4 chars + "...\0",
i.e. need room for 8 chars */
-
+
char *s, *end;
for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
int ch = *s & 0xFF;
}
if (PL_op)
- Perl_warner(aTHX_ WARN_NUMERIC,
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
"Argument \"%s\" isn't numeric in %s", pv,
OP_DESC(PL_op));
else
- Perl_warner(aTHX_ WARN_NUMERIC,
+ Perl_warner(aTHX_ packWARN(WARN_NUMERIC),
"Argument \"%s\" isn't numeric", pv);
}
STATIC int
S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype)
{
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
if (SvNVX(sv) < (NV)IV_MIN) {
(void)SvIOKp_on(sv);
(void)SvNOK_on(sv);
SvIVX(sv) = -(IV)value;
} else {
/* Too negative for an IV. This is a double upgrade, but
- I'm assuming it will be be rare. */
+ I'm assuming it will be rare. */
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvNOK_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
PTR2UV(sv), SvNVX(sv)));
#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"NVgf")\n",
PTR2UV(sv), SvNVX(sv)));
#endif
this NV is in the preserved range, therefore: */
if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
< (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
}
} else {
/* IN_UV NOT_INT
SvIVX(sv) = -(IV)value;
} else {
/* Too negative for an IV. This is a double upgrade, but
- I'm assuming it will be be rare. */
+ I'm assuming it will be rare. */
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvNOK_on(sv);
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
PTR2UV(sv), SvNVX(sv)));
#else
- DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"NVgf")\n",
PTR2UV(sv), SvNVX(sv)));
#endif
this NV is in the preserved range, therefore: */
if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
< (UV)IV_MAX)) {
- Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
+ Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%"NVgf" U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
}
} else
sv_2iuv_non_preserve (sv, numtype);
#else
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
+ PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%"NVgf")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
#else
DEBUG_c({
STORE_NUMERIC_LOCAL_SET_STANDARD();
- PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
+ PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%"NVgf")\n",
PTR2UV(sv), SvNVX(sv));
RESTORE_NUMERIC_LOCAL();
});
return ptr;
}
-/* For backwards-compatibility only. sv_2pv() is normally #def'ed to
- * C<sv_2pv_macro()>. See also C<sv_2pv_flags()>.
+/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
*/
char *
default: s = "UNKNOWN"; break;
}
tsv = NEWSV(0,0);
- if (SvOBJECT(sv))
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
+ if (SvOBJECT(sv)) {
+ HV *svs = SvSTASH(sv);
+ Perl_sv_setpvf(
+ aTHX_ tsv, "%s=%s",
+ /* [20011101.072] This bandaid for C<package;>
+ should eventually be removed. AMS 20011103 */
+ (svs ? HvNAME(svs) : "<none>"), s
+ );
+ }
else
sv_setpv(tsv, s);
Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
}
/*
+=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 (SvROK(sv)) {
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
- (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
+ (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv))))
return SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
+This is not as a general purpose byte encoding to Unicode interface:
+use the Encode extension for that.
+
=cut
*/
+/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags();
+ * this function provided for binary compatibility only
+ */
+
+
STRLEN
Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
{
will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
+This is not as a general purpose byte encoding to Unicode interface:
+use the Encode extension for that.
+
=cut
*/
}
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
}
if (hibit) {
STRLEN len;
-
+
len = SvCUR(sv) + 1; /* Plus the \0 */
SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
SvCUR(sv) = len - 1;
if this is the case, either returns false or, if C<fail_ok> is not
true, croaks.
+This is not as a general purpose Unicode to byte encoding interface:
+use the Encode extension for that.
+
=cut
*/
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",
=cut
*/
-/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
- for binary compatibility only
-*/
+/* sv_setsv() is now a macro using Perl_sv_setsv_flags();
+ * this function provided for binary compatibility only
+ */
+
void
Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
{
|| sv_cmp(cv_const_sv(cv),
cv_const_sv((CV*)sref)))))
{
- Perl_warner(aTHX_ WARN_REDEFINE,
+ Perl_warner(aTHX_ packWARN(WARN_REDEFINE),
CvCONST(cv)
? "Constant subroutine %s redefined"
: "Subroutine %s redefined",
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. */
}
else { /* have to copy actual string */
STRLEN len = SvCUR(sstr);
-
SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
Move(SvPVX(sstr),SvPVX(dstr),len,char);
SvCUR_set(dstr, len);
else {
if (dtype == SVt_PVGV) {
if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Undefined value assigned to typeglob");
}
else
(void)SvOK_off(dstr);
=cut
*/
-/* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
- for binary compatibility only
-*/
+/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags();
+ * this function provided for binary compatibility only
+ */
+
void
Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
{
=cut */
-/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
- for binary compatibility only
-*/
+/* sv_catsv() is now a macro using Perl_sv_catsv_flags();
+ * this function provided for binary compatibility only
+ */
+
void
Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
{
}
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'
-C<name> is assumed to contain an C<SV*> if C<(name && namelen == HEf_SVKEY)>
+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
+
+(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);
SvMAGIC(sv) = mg;
- /* Some magic contains a reference loop, where the sv and object refer to
- each other. To avoid a reference loop that would prevent such objects
- being freed, we look for such loops and if we find one we avoid
- incrementing the object refcount. */
+ /* Some magic sontains a reference loop, where the sv and object refer to
+ each other. To prevent a reference loop that would prevent such
+ objects being freed, we look for such loops and if we find one we
+ avoid incrementing the object refcount. */
if (!obj || obj == sv ||
how == PERL_MAGIC_arylen ||
how == PERL_MAGIC_qr ||
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);
Perl_croak(aTHX_ "Can't weaken a nonreference");
else if (SvWEAKREF(sv)) {
if (ckWARN(WARN_MISC))
- Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
+ Perl_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak");
return sv;
}
tsv = SvRV(sv);
SV **svp;
I32 i;
SV *tsv = SvRV(sv);
- MAGIC *mg;
+ MAGIC *mg = NULL;
if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
Perl_croak(aTHX_ "panic: del_backref");
av = (AV *)mg->mg_obj;
U32 refcnt = SvREFCNT(sv);
SV_CHECK_THINKFIRST(sv);
if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()");
if (SvMAGICAL(sv)) {
if (SvMAGICAL(nsv))
mg_free(nsv);
return;
}
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Attempt to free unreferenced scalar");
return;
}
ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
#ifdef DEBUGGING
if (SvTEMP(sv)) {
if (ckWARN_d(WARN_DEBUGGING))
- Perl_warner(aTHX_ WARN_DEBUGGING,
+ Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
"Attempt to free temp prematurely: SV 0x%"UVxf,
PTR2UV(sv));
return;
STRLEN cur2;
I32 eq = 0;
char *tpv = Nullch;
+ SV* svrecode = Nullsv;
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;
- }
+ /* 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;
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 = "";
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);
+ }
}
}
}
}
- if (pv1tmp)
- Safefree(pv1);
- if (pv2tmp)
- Safefree(pv2);
+ if (svrecode)
+ SvREFCNT_dec(svrecode);
+
+ if (tpv)
+ Safefree(tpv);
return cmp;
}
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
DEBUG_P(PerlIO_printf(Perl_debug_log,
- "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
+ "Screamer: entering: PerlIO * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
for (;;) {
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
PTR2UV(ptr),(long)cnt));
- PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
+ PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */
+#if 0
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+#endif
/* This used to call 'filbuf' in stdio form, but as that behaves like
getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
another abstraction. */
i = PerlIO_getc(fp); /* get more characters */
+#if 0
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
+#endif
cnt = PerlIO_get_cnt(fp);
ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
DEBUG_P(PerlIO_printf(Perl_debug_log,
cnt += shortbuffered;
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
- PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
+ PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv) && SvFAKE(sv))
+ sv_force_normal(sv);
if (SvREADONLY(sv)) {
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
#endif
if (SvIsUV(sv)) {
if (SvUVX(sv) == UV_MAX)
- sv_setnv(sv, (NV)UV_MAX + 1.0);
+ sv_setnv(sv, UV_MAX_P1);
else
(void)SvIOK_only_UV(sv);
++SvUVX(sv);
while (isDIGIT(*d)) d++;
if (*d) {
#ifdef PERL_PRESERVE_IVUV
- /* Got to punt this an an integer if needs be, but we don't issue
+ /* Got to punt this as an integer if needs be, but we don't issue
warnings. Probably ought to make the sv_iv_please() that does
the conversion if possible, and silently. */
int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
SvPVX(sv), SvIVX(sv), SvNVX(sv)));
#else
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
SvPVX(sv), SvIVX(sv), SvNVX(sv)));
#endif
}
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTHINKFIRST(sv)) {
+ if (SvREADONLY(sv) && SvFAKE(sv))
+ sv_force_normal(sv);
if (SvREADONLY(sv)) {
if (PL_curcop != &PL_compiling)
Perl_croak(aTHX_ PL_no_modify);
DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
SvPVX(sv), SvIVX(sv), SvNVX(sv)));
#else
- DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
+ DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"NVgf"\n",
SvPVX(sv), SvIVX(sv), SvNVX(sv)));
#endif
}
return Nullsv;
if (SvTYPE(old) == SVTYPEMASK) {
if (ckWARN_d(WARN_INTERNAL))
- Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
+ Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string");
return Nullsv;
}
new_SV(sv);
CV *
Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
{
- GV *gv;
- CV *cv;
+ GV *gv = Nullgv;
+ CV *cv = Nullcv;
STRLEN n_a;
if (!sv)
/*
=for apidoc sv_pv
-A private implementation of the C<SvPV_nolen> macro for compilers which can't
-cope with complex macro expressions. Always use the macro instead.
+Use the C<SvPV_nolen> macro instead
=cut
*/
+/* sv_pv() is now a macro using SvPV_nolen();
+ * this function provided for binary compatibility only
+ */
+
+
char *
Perl_sv_pv(pTHX_ SV *sv)
{
return sv_2pv(sv, lp);
}
-/* For -DCRIPPLED_CC only. See also C<sv_2pv_flags()>.
- */
char *
Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp)
=cut
*/
+/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags();
+ * this function provided for binary compatibility only
+ */
+
char *
Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
{
char *
Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
{
- char *s;
+ char *s = NULL;
if (SvTHINKFIRST(sv) && !SvROK(sv))
sv_force_normal(sv);
/*
=for apidoc sv_pvbyte
-A private implementation of the C<SvPVbyte_nolen> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
+Use C<SvPVbyte_nolen> instead.
=cut
*/
+/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+
char *
Perl_sv_pvbyte(pTHX_ SV *sv)
{
/*
=for apidoc sv_pvutf8
-A private implementation of the C<SvPVutf8_nolen> macro for compilers
-which can't cope with complex macro expressions. Always use the macro
-instead.
+Use the C<SvPVutf8_nolen> macro instead
=cut
*/
+/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
char *
Perl_sv_pvutf8(pTHX_ SV *sv)
char *
Perl_sv_reftype(pTHX_ SV *sv, int ob)
{
- if (ob && SvOBJECT(sv))
- return HvNAME(SvSTASH(sv));
+ if (ob && SvOBJECT(sv)) {
+ HV *svs = SvSTASH(sv);
+ /* [20011101.072] This bandaid for C<package;> should eventually
+ be removed. AMS 20011103 */
+ return (svs ? HvNAME(svs) : "<none>");
+ }
else {
switch (SvTYPE(sv)) {
case SVt_NULL:
mg_set(tmpRef);
-
+
return sv;
}
I32 svix = 0;
static char nullstr[] = "(null)";
SV *argsv = Nullsv;
+ bool has_utf8 = FALSE; /* has the result utf8? */
/* no matter what, this is a string now */
(void)SvPV_force(sv, origlen);
}
}
+ if (!args && svix < svmax && DO_UTF8(*svargs))
+ has_utf8 = TRUE;
+
patend = (char*)pat + patlen;
for (p = (char*)pat; p < patend; p = q) {
bool alt = FALSE;
bool left = FALSE;
bool vectorize = FALSE;
bool vectorarg = FALSE;
- bool vec_utf = FALSE;
+ bool vec_utf8 = FALSE;
char fill = ' ';
char plus = 0;
char intsize = 0;
STRLEN zeros = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
- bool is_utf = FALSE;
+ bool is_utf8 = FALSE; /* is this item utf8? */
char esignbuf[4];
U8 utf8buf[UTF8_MAXLEN+1];
SV *vecsv;
U8 *vecstr = Null(U8*);
STRLEN veclen = 0;
- char c;
+ char c = 0;
int i;
unsigned base = 0;
IV iv = 0;
svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
dotstr = SvPVx(vecsv, dotstrlen);
if (DO_UTF8(vecsv))
- is_utf = TRUE;
+ is_utf8 = TRUE;
}
if (args) {
vecsv = va_arg(*args, SV*);
vecstr = (U8*)SvPVx(vecsv,veclen);
- vec_utf = DO_UTF8(vecsv);
+ vec_utf8 = DO_UTF8(vecsv);
}
else if (efix ? efix <= svmax : svix < svmax) {
vecsv = svargs[efix ? efix-1 : svix++];
vecstr = (U8*)SvPVx(vecsv,veclen);
- vec_utf = DO_UTF8(vecsv);
+ vec_utf8 = DO_UTF8(vecsv);
}
else {
vecstr = (U8*)"";
&& !IN_BYTES) {
eptr = (char*)utf8buf;
elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
- is_utf = TRUE;
+ is_utf8 = TRUE;
}
else {
c = (char)uv;
if (width) { /* fudge width (can't fudge elen) */
width += elen - sv_len_utf8(argsv);
}
- is_utf = TRUE;
+ is_utf8 = TRUE;
}
}
goto string;
argsv = va_arg(*args, SV*);
eptr = SvPVx(argsv, elen);
if (DO_UTF8(argsv))
- is_utf = TRUE;
+ is_utf8 = TRUE;
string:
vectorize = FALSE;
STRLEN ulen;
if (!veclen)
continue;
- if (vec_utf)
- uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
+ if (vec_utf8)
+ uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+ UTF8_ALLOW_ANYUV);
else {
uv = *vecstr;
ulen = 1;
vector:
if (!veclen)
continue;
- if (vec_utf)
- uv = utf8n_to_uvchr(vecstr, veclen, &ulen, UTF8_ALLOW_ANYUV);
+ if (vec_utf8)
+ uv = utf8n_to_uvchr(vecstr, veclen, &ulen,
+ UTF8_ALLOW_ANYUV);
else {
uv = *vecstr;
ulen = 1;
if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
&& (n == 2 || !isDIGIT(s[n-3])))
{
- Perl_warner(aTHX_ WARN_Y2K,
+ Perl_warner(aTHX_ packWARN(WARN_Y2K),
"Possible Y2K bug: %%%c %s",
c, "format string following '19'");
}
(UV)c & 0xFF);
} else
sv_catpv(msg, "end of string");
- Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
+ Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, msg); /* yes, this is reentrant */
}
/* output mangled stuff ... */
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;
else
vectorize = FALSE; /* done iterating over vecstr */
}
- if (is_utf)
+ if (is_utf8)
+ has_utf8 = TRUE;
+ if (has_utf8)
SvUTF8_on(sv);
*p = '\0';
SvCUR(sv) = p - SvPVX(sv);
s->min_offset = r->substrs->data[i].min_offset;
s->max_offset = r->substrs->data[i].max_offset;
s->substr = sv_dup_inc(r->substrs->data[i].substr, param);
+ s->utf8_substr = sv_dup_inc(r->substrs->data[i].utf8_substr, param);
}
ret->regstclass = NULL;
return ret;
/* create anew and remember what it is */
- ret = PerlIO_fdupopen(aTHX_ fp, param);
+ ret = PerlIO_fdupopen(aTHX_ fp, param, PERLIO_DUP_CLONE);
ptr_table_store(PL_ptr_table, fp, ret);
return ret;
}
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;
/* duplicate an SV of any type (including AV, HV etc) */
+void
+Perl_rvpv_dup(pTHX_ SV *dstr, SV *sstr, CLONE_PARAMS* param)
+{
+ if (SvROK(sstr)) {
+ SvRV(dstr) = SvWEAKREF(sstr)
+ ? sv_dup(SvRV(sstr), param)
+ : sv_dup_inc(SvRV(sstr), param);
+ }
+ else if (SvPVX(sstr)) {
+ /* Has something there */
+ if (SvLEN(sstr)) {
+ /* 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)) {
+ /* A "shared" PV - clone it as unshared string */
+ SvFAKE_off(dstr);
+ SvREADONLY_off(dstr);
+ SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+ }
+ else {
+ /* Some other special case - random pointer */
+ SvPVX(dstr) = SvPVX(sstr);
+ }
+ }
+ }
+ else {
+ /* Copy the Null */
+ SvPVX(dstr) = SvPVX(sstr);
+ }
+}
+
SV *
Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param)
{
break;
case SVt_RV:
SvANY(dstr) = new_XRV();
- SvRV(dstr) = SvRV(sstr) && SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PV:
SvANY(dstr) = new_XPV();
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
- if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
- else if (SvPVX(sstr) && SvLEN(sstr))
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
- else
- SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVIV:
SvANY(dstr) = new_XPVIV();
SvCUR(dstr) = SvCUR(sstr);
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
- if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
- else if (SvPVX(sstr) && SvLEN(sstr))
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
- else
- SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVNV:
SvANY(dstr) = new_XPVNV();
SvLEN(dstr) = SvLEN(sstr);
SvIVX(dstr) = SvIVX(sstr);
SvNVX(dstr) = SvNVX(sstr);
- if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
- else if (SvPVX(sstr) && SvLEN(sstr))
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
- else
- SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVMG:
SvANY(dstr) = new_XPVMG();
SvNVX(dstr) = SvNVX(sstr);
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
- if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
- else if (SvPVX(sstr) && SvLEN(sstr))
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
- else
- SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
break;
case SVt_PVBM:
SvANY(dstr) = new_XPVBM();
SvNVX(dstr) = SvNVX(sstr);
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
- if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
- else if (SvPVX(sstr) && SvLEN(sstr))
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
- else
- SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
BmRARE(dstr) = BmRARE(sstr);
BmUSEFUL(dstr) = BmUSEFUL(sstr);
BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
SvNVX(dstr) = SvNVX(sstr);
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
- if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
- else if (SvPVX(sstr) && SvLEN(sstr))
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
- else
- SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
LvTARGLEN(dstr) = LvTARGLEN(sstr);
LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
SvNVX(dstr) = SvNVX(sstr);
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
- if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
- else if (SvPVX(sstr) && SvLEN(sstr))
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
- else
- SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
GvNAMELEN(dstr) = GvNAMELEN(sstr);
GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr), param);
SvNVX(dstr) = SvNVX(sstr);
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
- if (SvROK(sstr))
- SvRV(dstr) = SvWEAKREF(sstr)
- ? sv_dup(SvRV(sstr), param)
- : sv_dup_inc(SvRV(sstr), param);
- else if (SvPVX(sstr) && SvLEN(sstr))
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
- else
- SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr), param);
if (IoOFP(sstr) == IoIFP(sstr))
IoOFP(dstr) = IoIFP(dstr);
SvNVX(dstr) = SvNVX(sstr);
SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr), param);
SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr), param);
- if (SvPVX(sstr) && SvLEN(sstr))
- SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
- else
- SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
+ Perl_rvpv_dup(aTHX_ dstr, sstr, param);
CvSTASH(dstr) = hv_dup(CvSTASH(sstr), param); /* NOTE: not refcounted */
CvSTART(dstr) = CvSTART(sstr);
CvROOT(dstr) = OpREFCNT_inc(CvROOT(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);
* their pointers copied. */
IV i;
- CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
+ CLONE_PARAMS clone_params;
+ CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
PERL_SET_THX(my_perl);
PL_savestack = 0;
PL_retstack = 0;
PL_sig_pending = 0;
+ Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
# endif /* DEBUGGING */
PL_Proc = ipP;
#else /* !PERL_IMPLICIT_SYS */
IV i;
- CLONE_PARAMS* param = (CLONE_PARAMS*) malloc(sizeof(CLONE_PARAMS));
+ CLONE_PARAMS clone_params;
+ CLONE_PARAMS* param = &clone_params;
PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
PERL_SET_THX(my_perl);
PL_savestack = 0;
PL_retstack = 0;
PL_sig_pending = 0;
+ Zero(&PL_debug_pad, 1, struct perl_debug_pad);
# else /* !DEBUGGING */
Zero(my_perl, 1, PerlInterpreter);
# endif /* DEBUGGING */
PL_debug = proto_perl->Idebug;
#ifdef USE_REENTRANT_API
- New(31337, PL_reentrant_buffer,1, REBUF);
- New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
+ Perl_reentrant_init(aTHX);
#endif
/* create SV map for pointer relocation */
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);
#endif
PL_encoding = sv_dup(proto_perl->Iencoding, param);
+ sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */
+ sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */
+ sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */
+
/* Clone the regex array */
PL_regex_padav = newAV();
{
PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param);
PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param);
PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param);
+ PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param);
/* swatch cache */
PL_last_swash_hv = Nullhv; /* reinits on demand */
}
SvREFCNT_dec(param->stashes);
- Safefree(param);
return my_perl;
}
#endif /* USE_ITHREADS */
/*
+=head1 Unicode Support
+
=for apidoc sv_recode_to_utf8
The encoding is assumed to be an Encode object, on entry the PV
If the sv already is UTF-8 (or if it is not POK), or if the encoding
is not a reference, nothing is done to the sv. If the encoding is not
-Encode object, bad things happen.
+an C<Encode::XS> Encoding object, bad things will happen.
+(See F<lib/encoding.pm> and L<Encode>).
The PV of the sv is returned.
char *
Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding)
{
- if (SvPOK(sv) && !SvUTF8(sv) && SvROK(encoding)) {
+ if (SvPOK(sv) && !DO_UTF8(sv) && SvROK(encoding)) {
SV *uni;
STRLEN len;
char *s;
SPAGAIN;
uni = POPs;
PUTBACK;
- s = SvPVutf8(uni, len);
+ s = SvPV(uni, len);
if (s != SvPVX(sv)) {
SvGROW(sv, len);
Move(s, SvPVX(sv), len, char);
return SvPVX(sv);
}
+
https://perl5.git.perl.org / perl5.git / blobdiff