/* 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)
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));
=for apidoc sv_2pvbyte_nolen
Return a pointer to the byte-encoded representation of the SV.
-May cause the SV to be downgraded from UTF8 as a side-effect.
+May cause the SV to be downgraded from UTF-8 as a side-effect.
Usually accessed via the C<SvPVbyte_nolen> macro.
=for apidoc sv_2pvbyte
Return a pointer to the byte-encoded representation of the SV, and set *lp
-to its length. May cause the SV to be downgraded from UTF8 as a
+to its length. May cause the SV to be downgraded from UTF-8 as a
side-effect.
Usually accessed via the C<SvPVbyte> macro.
/*
=for apidoc sv_2pvutf8_nolen
-Return a pointer to the UTF8-encoded representation of the SV.
-May cause the SV to be upgraded to UTF8 as a side-effect.
+Return a pointer to the UTF-8-encoded representation of the SV.
+May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8_nolen> macro.
/*
=for apidoc sv_2pvutf8
-Return a pointer to the UTF8-encoded representation of the SV, and set *lp
-to its length. May cause the SV to be upgraded to UTF8 as a side-effect.
+Return a pointer to the UTF-8-encoded representation of the SV, and set *lp
+to its length. May cause the SV to be upgraded to UTF-8 as a side-effect.
Usually accessed via the C<SvPVutf8> macro.
}
}
+/* 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
-Convert the PV of an SV to its UTF8-encoded form.
+Convert the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear.
=for apidoc sv_utf8_upgrade_flags
-Convert the PV of an SV to its UTF8-encoded form.
+Convert the PV of an SV to its UTF-8-encoded form.
Forces the SV to string form if it is not already.
Always sets the SvUTF8 flag to avoid future validity checks even
if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
/*
=for apidoc sv_utf8_downgrade
-Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
+Attempt to convert the PV of an SV from UTF-8-encoded to byte encoding.
This may not be possible if the PV contains non-byte encoding characters;
if this is the case, either returns false or, if C<fail_ok> is not
true, croaks.
/*
=for apidoc sv_utf8_encode
-Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
+Convert the PV of an SV to UTF-8-encoded, but then turn off the C<SvUTF8>
flag so that it looks like octets again. Used as a building block
for encode_utf8 in Encode.xs
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. */
sv_dump(sv);
}
}
- else if (PL_curcop != &PL_compiling)
+ else if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
/* At this point I believe that I can drop the global SV mutex. */
}
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)
+ else if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
#endif
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
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF8
-status set, then the bytes appended should be valid UTF8.
+C<len> indicates number of bytes to copy. If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
=for apidoc sv_catpvn_flags
Concatenates the string onto the end of the string which is in the SV. The
-C<len> indicates number of bytes to copy. If the SV has the UTF8
-status set, then the bytes appended should be valid UTF8.
+C<len> indicates number of bytes to copy. If the SV has the UTF-8
+status set, then the bytes appended should be valid UTF-8.
If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
in terms of this function.
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
=for apidoc sv_catpv
Concatenates the string onto the end of the string which is in the SV.
-If the SV has the UTF8 status set, then the bytes appended should be
-valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
+If the SV has the UTF-8 status set, then the bytes appended should be
+valid UTF-8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
=cut */
sv_force_normal_flags(sv, 0);
#endif
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling
+ if (IN_PERL_RUNTIME
&& how != PERL_MAGIC_regex_global
&& how != PERL_MAGIC_bm
&& how != PERL_MAGIC_fm
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);
=for apidoc sv_len_utf8
Returns the number of characters in the string in an SV, counting wide
-UTF8 bytes as a single character. Handles magic and type coercion.
+UTF-8 bytes as a single character. Handles magic and type coercion.
=cut
*/
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;
}
/*
=for apidoc sv_pos_u2b
-Converts the value pointed to by offsetp from a count of UTF8 chars from
+Converts the value pointed to by offsetp from a count of UTF-8 chars from
the start of the string, to a count of the equivalent number of bytes; if
lenp is non-zero, it does the same to lenp, but this time starting from
the offset, rather than from the start of the string. Handles magic and
}
*lenp = s - start;
}
+ ASSERT_UTF8_CACHE(cache);
}
else {
*offsetp = 0;
if (lenp)
*lenp = 0;
}
+
return;
}
=for apidoc sv_pos_b2u
Converts the value pointed to by offsetp from a count of bytes from the
-start of the string, to a count of the equivalent number of UTF8 chars.
+start of the string, to a count of the equivalent number of UTF-8 chars.
Handles magic and type coercion.
=cut
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
if (PerlIO_isutf8(fp))
SvUTF8_on(sv);
- if (PL_curcop == &PL_compiling) {
+ if (IN_PERL_COMPILETIME) {
/* we always read code in line mode */
rsptr = "\n";
rslen = 1;
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 return_string_or_null;
}
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 */
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling)
+ if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv)) {
if (SvIsCOW(sv))
sv_force_normal_flags(sv, 0);
if (SvREADONLY(sv)) {
- if (PL_curcop != &PL_compiling)
+ if (IN_PERL_RUNTIME)
Perl_croak(aTHX_ PL_no_modify);
}
if (SvROK(sv)) {
}
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);
longval = (long)POPBOOL(ss,ix);
TOPBOOL(nss,ix) = (bool)longval;
break;
+ case SAVEt_SET_SVFLAGS:
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ i = POPINT(ss,ix);
+ TOPINT(nss,ix) = i;
+ sv = (SV*)POPPTR(ss,ix);
+ TOPPTR(nss,ix) = sv_dup(sv, param);
+ break;
default:
Perl_croak(aTHX_ "panic: ss_dup inconsistency");
}
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;
}