/* 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.
s = "REF";
else
s = "SCALAR"; break;
- case SVt_PVLV: s = "LVALUE"; break;
+ case SVt_PVLV: s = SvROK(sv) ? "REF":"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));
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;
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);
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;
}
}
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;
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" : "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);
}
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);
/* 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_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;
/* 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;