/* 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)
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));
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
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;
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) {
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 (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 */
}
}
}
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.
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;
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);
/* 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;