/* sv.c
*
- * Copyright (c) 1991-2003, Larry Wall
+ * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
+ * 2000, 2001, 2002, 2003, by Larry Wall and others
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#define FCALL *f
+#ifdef PERL_UTF8_CACHE_ASSERT
+/* The cache element 0 is the Unicode offset;
+ * the cache element 1 is the byte offset of the element 0;
+ * the cache element 2 is the Unicode length of the substring;
+ * the cache element 3 is the byte length of the substring;
+ * The checking of the substring side would be good
+ * but substr() has enough code paths to make my head spin;
+ * if adding more checks watch out for the following tests:
+ * t/op/index.t t/op/length.t t/op/pat.t t/op/substr.t
+ * lib/utf8.t lib/Unicode/Collate/t/index.t
+ * --jhi
+ */
+#define ASSERT_UTF8_CACHE(cache) \
+ STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); } } STMT_END
+#else
+#define ASSERT_UTF8_CACHE(cache) NOOP
+#endif
+
#ifdef PERL_COPY_ON_WRITE
#define SV_COW_NEXT_SV(sv) INT2PTR(SV *,SvUVX(sv))
#define SV_COW_NEXT_SV_SET(current,next) SvUVX(current) = PTR2UV(next)
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)=%"NVgf" 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((double)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
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)=%"NVgf" 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((double)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);
return ptr;
}
+/* sv_2pv() is now a macro using Perl_sv_2pv_flags();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
+{
+ return sv_2pv_flags(sv, lp, SV_GMAGIC);
+}
+
/*
=for apidoc sv_2pv_flags
s = "REF";
else
s = "SCALAR"; break;
- case SVt_PVLV: s = "LVALUE"; break;
+ case SVt_PVLV: s = SvROK(sv) ? "REF"
+ /* tied lvalues should appear to be
+ * scalars for backwards compatitbility */
+ : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+ ? "SCALAR" : "LVALUE"; break;
case SVt_PVAV: s = "ARRAY"; break;
case SVt_PVHV: s = "HASH"; break;
case SVt_PVCV: s = "CODE"; break;
}
tsv = NEWSV(0,0);
if (SvOBJECT(sv))
- Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
+ if (HvNAME(SvSTASH(sv)))
+ Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
+ else
+ Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s);
else
sv_setpv(tsv, s);
Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
}
}
+/* 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)
+{
+ return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
+}
+
/*
=for apidoc sv_utf8_upgrade
return TRUE;
}
+/* 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_setsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
/*
=for apidoc sv_setsv
if (dtype < SVt_RV)
sv_upgrade(dstr, SVt_RV);
else if (dtype == SVt_PVGV &&
- SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ SvROK(sstr) && SvTYPE(SvRV(sstr)) == SVt_PVGV) {
sstr = SvRV(sstr);
if (sstr == dstr) {
if (GvIMPORTED(dstr) != GVf_IMPORTED
goto glob_assign;
}
break;
- case SVt_PV:
case SVt_PVFM:
+#ifdef PERL_COPY_ON_WRITE
+ if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) {
+ if (dtype < SVt_PVIV)
+ sv_upgrade(dstr, SVt_PVIV);
+ break;
+ }
+ /* Fall through */
+#endif
+ case SVt_PV:
if (dtype < SVt_PV)
sv_upgrade(dstr, SVt_PV);
break;
/* making another shared SV. */
STRLEN cur = SvCUR(sstr);
STRLEN len = SvLEN(sstr);
+ assert (SvTYPE(dstr) >= SVt_PVIV);
if (len) {
/* SvIsCOW_normal */
/* splice us in between source and next-after-source. */
char *pvx = SvPVX(sv);
STRLEN len = SvCUR(sv);
U32 hash = SvUVX(sv);
+ SvFAKE_off(sv);
+ SvREADONLY_off(sv);
SvGROW(sv, len + 1);
Move(pvx,SvPVX(sv),len,char);
*SvEND(sv) = '\0';
- SvFAKE_off(sv);
- SvREADONLY_off(sv);
unsharepvn(pvx, SvUTF8(sv) ? -(I32)len : len, hash);
}
else if (PL_curcop != &PL_compiling)
SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
the string buffer. The C<ptr> becomes the first character of the adjusted
string. Uses the "OOK hack".
+Beware: after this function returns, C<ptr> and SvPVX(sv) may no longer
+refer to the same chunk of data.
=cut
*/
Perl_sv_chop(pTHX_ register SV *sv, register char *ptr)
{
register STRLEN delta;
-
if (!ptr || !SvPOKp(sv))
return;
+ delta = ptr - SvPVX(sv);
SV_CHECK_THINKFIRST(sv);
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv,SVt_PVIV);
SvFLAGS(sv) |= SVf_OOK;
}
SvNIOK_off(sv);
- delta = ptr - SvPVX(sv);
SvLEN(sv) -= delta;
SvCUR(sv) -= delta;
SvPVX(sv) += delta;
SvIVX(sv) += delta;
}
+/* 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)
+{
+ sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
+}
+
/*
=for apidoc sv_catpvn
SvSETMAGIC(sv);
}
+/* 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)
+{
+ sv_catsv_flags(dstr, sstr, SV_GMAGIC);
+}
+
/*
=for apidoc sv_catsv
else {
av = newAV();
sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
- SvREFCNT_dec(av); /* for sv_magic */
+ /* av now has a refcnt of 2, which avoids it getting freed
+ * before us during global cleanup. The extra ref is removed
+ * by magic_killbackrefs() when tsv is being freed */
}
if (AvFILLp(av) >= AvMAX(av)) {
SV **svp = AvARRAY(av);
#endif
SvREFCNT(sv) = refcnt;
SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
+ SvREFCNT(nsv) = 0;
del_SV(nsv);
}
if (PL_defstash) { /* Still have a symbol table? */
dSP;
CV* destructor;
- SV tmpref;
- Zero(&tmpref, 1, SV);
- sv_upgrade(&tmpref, SVt_RV);
- SvROK_on(&tmpref);
- SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
- SvREFCNT(&tmpref) = 1;
+
do {
stash = SvSTASH(sv);
destructor = StashHANDLER(stash,DESTROY);
if (destructor) {
+ SV* tmpref = newRV(sv);
+ SvREADONLY_on(tmpref); /* DESTROY() could be naughty */
ENTER;
PUSHSTACKi(PERLSI_DESTROY);
- SvRV(&tmpref) = SvREFCNT_inc(sv);
EXTEND(SP, 2);
PUSHMARK(SP);
- PUSHs(&tmpref);
+ PUSHs(tmpref);
PUTBACK;
call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID);
- SvREFCNT(sv)--;
+
+
POPSTACK;
SPAGAIN;
LEAVE;
+ if(SvREFCNT(tmpref) < 2) {
+ /* tmpref is not kept alive! */
+ SvREFCNT(sv)--;
+ SvRV(tmpref) = 0;
+ SvROK_off(tmpref);
+ }
+ SvREFCNT_dec(tmpref);
}
} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
- del_XRV(SvANY(&tmpref));
if (SvREFCNT(sv)) {
if (PL_in_clean_objs)
av_undef((AV*)sv);
break;
case SVt_PVLV:
- SvREFCNT_dec(LvTARG(sv));
+ if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */
+ SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv)));
+ HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh;
+ PL_hv_fetch_ent_mh = (HE*)LvTARG(sv);
+ }
+ else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */
+ SvREFCNT_dec(LvTARG(sv));
goto freescalar;
case SVt_PVGV:
gp_free((GV*)sv);
U8 *s = (U8*)SvPV(sv, len);
MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : 0;
- if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0))
+ if (mg && mg->mg_len != -1 && (mg->mg_len > 0 || len == 0)) {
ulen = mg->mg_len;
+#ifdef PERL_UTF8_CACHE_ASSERT
+ assert(ulen == Perl_utf8_length(aTHX_ s, s + len));
+#endif
+ }
else {
ulen = Perl_utf8_length(aTHX_ s, s + len);
if (!mg && !SvREADONLY(sv)) {
*mgp = mg_find(sv, PERL_MAGIC_utf8);
if (*mgp && (*mgp)->mg_ptr) {
*cachep = (STRLEN *) (*mgp)->mg_ptr;
+ ASSERT_UTF8_CACHE(*cachep);
if ((*cachep)[i] == (STRLEN)uoff) /* An exact match. */
- found = TRUE;
+ found = TRUE;
else { /* We will skip to the right spot. */
STRLEN forw = 0;
STRLEN backw = 0;
}
}
}
+#ifdef PERL_UTF8_CACHE_ASSERT
+ if (found) {
+ U8 *s = start;
+ I32 n = uoff;
+
+ while (n-- && s < send)
+ s += UTF8SKIP(s);
+
+ if (i == 0) {
+ assert(*offsetp == s - start);
+ assert((*cachep)[0] == (STRLEN)uoff);
+ assert((*cachep)[1] == *offsetp);
+ }
+ ASSERT_UTF8_CACHE(*cachep);
+ }
+#endif
}
+
return found;
}
}
*lenp = s - start;
}
+ ASSERT_UTF8_CACHE(cache);
}
else {
*offsetp = 0;
if (lenp)
*lenp = 0;
}
+
return;
}
mg = mg_find(sv, PERL_MAGIC_utf8);
if (mg && mg->mg_ptr) {
cache = (STRLEN *) mg->mg_ptr;
- if (cache[1] == *offsetp) {
+ if (cache[1] == (STRLEN)*offsetp) {
/* An exact match. */
*offsetp = cache[0];
return;
}
- else if (cache[1] < *offsetp) {
+ else if (cache[1] < (STRLEN)*offsetp) {
/* We already know part of the way. */
len = cache[0];
s += cache[1];
while (backw--) {
p--;
- while (UTF8_IS_CONTINUATION(*p))
+ while (UTF8_IS_CONTINUATION(*p)) {
p--;
+ backw--;
+ }
ubackw++;
}
cache[0] -= ubackw;
-
+ *offsetp = cache[0];
return;
}
}
}
+ ASSERT_UTF8_CACHE(cache);
}
while (s < send) {
I32 rspara = 0;
I32 recsize;
- SV_CHECK_THINKFIRST_COW_DROP(sv);
+ if (SvTHINKFIRST(sv))
+ sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV);
/* XXX. If you make this PVIV, then copy on write can copy scalars read
from <>.
However, perlbench says it's slower, because the existing swipe code
(void)SvUPGRADE(sv, SVt_PV);
SvSCREAM_off(sv);
- SvPOK_only(sv); /* Validate pointer */
+
+ if (append) {
+ if (PerlIO_isutf8(fp)) {
+ if (!SvUTF8(sv)) {
+ sv_utf8_upgrade_nomg(sv);
+ sv_pos_u2b(sv,&append,0);
+ }
+ } else if (SvUTF8(sv)) {
+ SV *tsv = NEWSV(0,0);
+ sv_gets(tsv, fp, 0);
+ sv_utf8_upgrade_nomg(tsv);
+ SvCUR_set(sv,append);
+ sv_catsv(sv,tsv);
+ sv_free(tsv);
+ goto return_string_or_null;
+ }
+ }
+
+ SvPOK_only(sv);
+ if (PerlIO_isutf8(fp))
+ SvUTF8_on(sv);
if (PL_curcop == &PL_compiling) {
/* we always read code in line mode */
Stat_t st;
if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) {
Off_t offset = PerlIO_tell(fp);
- if (offset != (Off_t) -1) {
+ if (offset != (Off_t) -1 && st.st_size + append > offset) {
(void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1));
}
}
#else
bytesread = PerlIO_read(fp, buffer, recsize);
#endif
+ if (bytesread < 0)
+ bytesread = 0;
SvCUR_set(sv, bytesread += append);
buffer[bytesread] = '\0';
- goto check_utf8_and_return;
+ goto return_string_or_null;
}
else if (RsPARA(PL_rs)) {
rsptr = "\n\n";
}
else
{
-#ifndef EPOC
- /*The big, slow, and stupid way */
- STDCHAR buf[8192];
+ /*The big, slow, and stupid way. */
+
+ /* Any stack-challenged places. */
+#if defined(EPOC)
+ /* EPOC: need to work around SDK features. *
+ * On WINS: MS VC5 generates calls to _chkstk, *
+ * if a "large" stack frame is allocated. *
+ * gcc on MARM does not generate calls like these. */
+# define USEHEAPINSTEADOFSTACK
+#endif
+
+#ifdef USEHEAPINSTEADOFSTACK
+ STDCHAR *buf = 0;
+ New(0, buf, 8192, STDCHAR);
+ assert(buf);
#else
- /* Need to work around EPOC SDK features */
- /* On WINS: MS VC5 generates calls to _chkstk, */
- /* if a `large' stack frame is allocated */
- /* gcc on MARM does not generate calls like these */
- STDCHAR buf[1024];
+ STDCHAR buf[8192];
#endif
screamer2:
if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
goto screamer2;
}
+
+#ifdef USEHEAPINSTEADOFSTACK
+ Safefree(buf);
+#endif
}
if (rspara) { /* have to do this both before and after */
}
}
-check_utf8_and_return:
- if (PerlIO_isutf8(fp))
- SvUTF8_on(sv);
- else
- SvUTF8_off(sv);
-
+return_string_or_null:
return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
}
if (GvHV(gv) && !HvNAME(GvHV(gv))) {
hv_clear(GvHV(gv));
+#ifndef PERL_MICRO
#ifdef USE_ENVIRON_ARRAY
if (gv == PL_envgv
# ifdef USE_ITHREADS
environ[0] = Nullch;
}
#endif
+#endif /* !PERL_MICRO */
}
}
}
return sv_2nv(sv);
}
+/* sv_pv() is now a macro using SvPV_nolen();
+ * this function provided for binary compatibility only
+ */
+
+char *
+Perl_sv_pv(pTHX_ SV *sv)
+{
+ STRLEN n_a;
+
+ if (SvPOK(sv))
+ return SvPVX(sv);
+
+ return sv_2pv(sv, &n_a);
+}
+
/*
=for apidoc sv_pv
return sv_2pv_flags(sv, lp, 0);
}
+/* 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)
+{
+ return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
+}
+
/*
=for apidoc sv_pvn_force
return SvPVX(sv);
}
+/* 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)
+{
+ sv_utf8_downgrade(sv,0);
+ return sv_pv(sv);
+}
+
/*
=for apidoc sv_pvbyte
return sv_pvn_force(sv,lp);
}
+/* 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)
+{
+ sv_utf8_upgrade(sv);
+ return sv_pv(sv);
+}
+
/*
=for apidoc sv_pvutf8
Perl_sv_reftype(pTHX_ SV *sv, int ob)
{
if (ob && SvOBJECT(sv)) {
- return HvNAME(SvSTASH(sv));
+ if (HvNAME(SvSTASH(sv)))
+ return HvNAME(SvSTASH(sv));
+ else
+ return "__ANON__";
}
else {
switch (SvTYPE(sv)) {
return "REF";
else
return "SCALAR";
- case SVt_PVLV: return "LVALUE";
+
+ case SVt_PVLV: return SvROK(sv) ? "REF"
+ /* tied lvalues should appear to be
+ * scalars for backwards compatitbility */
+ : (LvTYPE(sv) == 't' || LvTYPE(sv) == 'T')
+ ? "SCALAR" : "LVALUE";
case SVt_PVAV: return "ARRAY";
case SVt_PVHV: return "HASH";
case SVt_PVCV: return "CODE";
sv = (SV*)SvRV(sv);
if (!SvOBJECT(sv))
return 0;
+ if (!HvNAME(SvSTASH(sv)))
+ return 0;
return strEQ(HvNAME(SvSTASH(sv)), name);
}
the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
into the SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
Do not use with other Perl types such as HV, AV, SV, CV, because those
objects will become corrupted by the pointer copy process.
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
=cut
*/
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
=cut
*/
argument will be upgraded to an RV. That RV will be modified to point to
the new SV. The C<classname> argument indicates the package for the
blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
-will be returned and will have a reference count of 1.
+will have a reference count of 1, and the RV will be returned.
=cut
*/
string must be specified with C<n>. The C<rv> argument will be upgraded to
an RV. That RV will be modified to point to the new SV. The C<classname>
argument indicates the package for the blessing. Set C<classname> to
-C<Nullch> to avoid the blessing. The new SV will be returned and will have
-a reference count of 1.
+C<Nullch> to avoid the blessing. The new SV will have a reference count
+of 1, and the RV will be returned.
Note that C<sv_setref_pv> copies the pointer while this copies the string.
return FALSE;
}
+/*
+=for apidoc sv_setpviv
+
+Copies an integer into the given SV, also updating its string value.
+Does not handle 'set' magic. See C<sv_setpviv_mg>.
+
+=cut
+*/
+
+void
+Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
+{
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+
+ sv_setpvn(sv, ptr, ebuf - ptr);
+}
+
+/*
+=for apidoc sv_setpviv_mg
+
+Like C<sv_setpviv>, but also handles 'set' magic.
+
+=cut
+*/
+
+void
+Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
+{
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+
+ sv_setpvn(sv, ptr, ebuf - ptr);
+ SvSETMAGIC(sv);
+}
+
#if defined(PERL_IMPLICIT_CONTEXT)
/* pTHX_ magic can't cope with varargs, so this is a no-context
STRLEN zeros = 0;
bool has_precis = FALSE;
STRLEN precis = 0;
+ I32 osvix = svix;
bool is_utf8 = FALSE; /* is this item utf8? */
#ifdef HAS_LDBL_SPRINTF_BUG
/* This is to try to fix a bug with irix/nonstop-ux/powerux and
vecsv = va_arg(*args, SV*);
else
vecsv = (evix ? evix <= svmax : svix < svmax) ?
- svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
+ svargs[evix ? evix-1 : svix++] : &PL_sv_undef;
dotstr = SvPVx(vecsv, dotstrlen);
if (DO_UTF8(vecsv))
is_utf8 = TRUE;
default:
unknown:
- vectorize = FALSE;
if (!args && ckWARN(WARN_PRINTF) &&
(PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
SV *msg = sv_newmortal();
p += elen;
*p = '\0';
SvCUR(sv) = p - SvPVX(sv);
+ svix = osvix;
continue; /* not "break" */
}
p = SvEND(sv);
*p = '\0';
}
+ /* Use memchr() instead of strchr(), as eptr is not guaranteed */
+ /* to point to a null-terminated string. */
+ if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) &&
+ (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF))
+ Perl_warner(aTHX_ packWARN(WARN_PRINTF),
+ "Newline in left-justified string for %sprintf",
+ (PL_op->op_type == OP_PRTF) ? "" : "s");
have = esignlen + zeros + elen;
need = (have > width ? have : width);
/* 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));
+ if(SvPADTMP(sstr)) {
+ /* However, some of them live in the pad
+ and they should not have these flags
+ turned off */
+
+ SvPVX(dstr) = sharepvn(SvPVX(sstr), SvCUR(sstr),
+ SvUVX(sstr));
+ SvUVX(dstr) = SvUVX(sstr);
+ } else {
+
+ SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvCUR(sstr));
+ SvFAKE_off(dstr);
+ SvREADONLY_off(dstr);
+ }
}
else {
/* Some other special case - random pointer */
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);
+ if (LvTYPE(sstr) == 't') /* for tie: unrefcnted fake (SV**) */
+ LvTARG(dstr) = dstr;
+ else if (LvTYPE(sstr) == 'T') /* for tie: fake HE */
+ LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(sstr), 0, param);
+ else
+ LvTARG(dstr) = sv_dup_inc(LvTARG(sstr), param);
LvTYPE(dstr) = LvTYPE(sstr);
break;
case SVt_PVGV:
IoPAGE(dstr) = IoPAGE(sstr);
IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
+ if(IoFLAGS(sstr) & IOf_FAKE_DIRP) {
+ /* I have no idea why fake dirp (rsfps)
+ should be treaded differently but otherwise
+ we end up with leaks -- sky*/
+ IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param);
+ IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param);
+ IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param);
+ } else {
+ IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
+ IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
+ IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
+ }
IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
- IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param);
IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
- IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param);
IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
- IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param);
IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
IoTYPE(dstr) = IoTYPE(sstr);
IoFLAGS(dstr) = IoFLAGS(sstr);
Create and return a new interpreter by cloning the current one.
-perl_clone takes these flags as paramters:
+perl_clone takes these flags as parameters:
CLONEf_COPY_STACKS - is used to, well, copy the stacks also,
without it we only clone the data and zero the stacks,
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
+ PL_savestack_ix = 0;
+ PL_savestack_max = -1;
PL_retstack = 0;
PL_sig_pending = 0;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
PL_markstack = 0;
PL_scopestack = 0;
PL_savestack = 0;
+ PL_savestack_ix = 0;
+ PL_savestack_max = -1;
PL_retstack = 0;
PL_sig_pending = 0;
Zero(&PL_debug_pad, 1, struct perl_debug_pad);
/* internal state */
PL_tainting = proto_perl->Itainting;
+ PL_taint_warn = proto_perl->Itaint_warn;
PL_maxo = proto_perl->Imaxo;
if (proto_perl->Iop_mask)
PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
PL_origalen = proto_perl->Iorigalen;
PL_pidstatus = newHV(); /* XXX flag for cloning? */
PL_osname = SAVEPV(proto_perl->Iosname);
- PL_sh_path = proto_perl->Ish_path; /* XXX never deallocated */
+ PL_sh_path_compat = proto_perl->Ish_path_compat; /* XXX never deallocated */
PL_sighandlerp = proto_perl->Isighandlerp;
PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param);
PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param);
+ /* Did the locale setup indicate UTF-8? */
+ PL_utf8locale = proto_perl->Iutf8locale;
+ /* Unicode features (see perlrun/-C) */
+ PL_unicode = proto_perl->Iunicode;
+
+ /* Pre-5.8 signals control */
+ PL_signals = proto_perl->Isignals;
+
+ /* times() ticks per second */
+ PL_clocktick = proto_perl->Iclocktick;
+
+ /* Recursion stopper for PerlIO_find_layer */
+ PL_in_load_module = proto_perl->Iin_load_module;
+
+ /* sort() routine */
+ PL_sort_RealCmp = proto_perl->Isort_RealCmp;
+
+ /* Not really needed/useful since the reenrant_retint is "volatile",
+ * but do it for consistency's sake. */
+ PL_reentrant_retint = proto_perl->Ireentrant_retint;
+
+ /* Hooks to shared SVs and locks. */
+ PL_sharehook = proto_perl->Isharehook;
+ PL_lockhook = proto_perl->Ilockhook;
+ PL_unlockhook = proto_perl->Iunlockhook;
+ PL_threadhook = proto_perl->Ithreadhook;
+
+ PL_runops_std = proto_perl->Irunops_std;
+ PL_runops_dbg = proto_perl->Irunops_dbg;
+
+#ifdef THREADS_HAVE_PIDS
+ PL_ppid = proto_perl->Ippid;
+#endif
+
/* swatch cache */
PL_last_swash_hv = Nullhv; /* reinits on demand */
PL_last_swash_klen = 0;
PL_glob_index = proto_perl->Iglob_index;
PL_srand_called = proto_perl->Isrand_called;
+ PL_hash_seed = proto_perl->Ihash_seed;
PL_uudmap['M'] = 0; /* reinits on demand */
PL_bitcount = Nullch; /* reinits on demand */
PL_protect = proto_perl->Tprotect;
#endif
PL_errors = sv_dup_inc(proto_perl->Terrors, param);
- PL_av_fetch_sv = Nullsv;
- PL_hv_fetch_sv = Nullsv;
- Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
+ PL_hv_fetch_ent_mh = Nullhe;
PL_modcount = proto_perl->Tmodcount;
PL_lastgotoprobe = Nullop;
PL_dumpindent = proto_perl->Tdumpindent;
PL_regstartp = (I32*)NULL;
PL_regendp = (I32*)NULL;
PL_reglastparen = (U32*)NULL;
+ PL_reglastcloseparen = (U32*)NULL;
PL_regtill = Nullch;
PL_reg_start_tmp = (char**)NULL;
PL_reg_start_tmpl = 0;
/* Pluggable optimizer */
PL_peepp = proto_perl->Tpeepp;
+ PL_stashcache = newHV();
+
if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
ptr_table_free(PL_ptr_table);
PL_ptr_table = NULL;
Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding,
SV *ssv, int *offset, char *tstr, int tlen)
{
+ bool ret = FALSE;
if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) {
- bool ret = FALSE;
SV *offsv;
dSP;
ENTER;
PUTBACK;
FREETMPS;
LEAVE;
- return ret;
}
- Perl_croak(aTHX_ "Invalid argument to sv_cat_decode.");
+ else
+ Perl_croak(aTHX_ "Invalid argument to sv_cat_decode");
+ return ret;
}