#include "EXTERN.h"
#include "perl.h"
+#ifdef OVR_DBL_DIG
+/* Use an overridden DBL_DIG */
+# ifdef DBL_DIG
+# undef DBL_DIG
+# endif
+# define DBL_DIG OVR_DBL_DIG
+#else
/* The following is all to get DBL_DIG, in order to pick a nice
default value for printing floating point numbers in Gconvert.
(see config.h)
#ifndef HAS_DBL_DIG
#define DBL_DIG 15 /* A guess that works lots of places */
#endif
+#endif
+
+#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+# define FAST_SV_GETS
+#endif
static SV *more_sv _((void));
static XPVIV *more_xiv _((void));
#define new_SV() sv = (SV*)safemalloc(sizeof(SV))
#define del_SV(p) free((char*)p)
+void
+sv_add_arena(ptr, size, flags)
+char* ptr;
+U32 size;
+U32 flags;
+{
+ if (!(flags & SVf_FAKE))
+ free(ptr);
+}
+
#else
#define new_SV() \
SV* p;
{
if (debug & 32768) {
+ SV* sva;
SV* sv;
SV* svend;
int ok = 0;
- for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(svend)) {
- svend = &sv[1008 / sizeof(SV)];
+ for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
+ sv = sva + 1;
+ svend = &sva[SvREFCNT(sva)];
if (p >= sv && p < svend)
ok = 1;
}
#endif
-static SV*
-more_sv()
+void
+sv_add_arena(ptr, size, flags)
+char* ptr;
+U32 size;
+U32 flags;
{
+ SV* sva = (SV*)ptr;
register SV* sv;
register SV* svend;
- sv_root = (SV*)safemalloc(1012);
- sv = sv_root;
- Zero(sv, 1012, char);
- svend = &sv[1008 / sizeof(SV) - 1];
+ Zero(sva, size, char);
+
+ /* The first SV in an arena isn't an SV. */
+ SvANY(sva) = (void *) sv_arenaroot; /* ptr to next arena */
+ SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
+ SvFLAGS(sva) = flags; /* FAKE if not to be freed */
+
+ sv_arenaroot = sva;
+ sv_root = sva + 1;
+
+ svend = &sva[SvREFCNT(sva) - 1];
+ sv = sva + 1;
while (sv < svend) {
SvANY(sv) = (void *)(SV*)(sv + 1);
SvFLAGS(sv) = SVTYPEMASK;
sv++;
}
SvANY(sv) = 0;
- sv++;
- SvANY(sv) = (void *) sv_arenaroot;
- sv_arenaroot = sv_root;
+ SvFLAGS(sv) = SVTYPEMASK;
+}
+
+static SV*
+more_sv()
+{
+ if (nice_chunk) {
+ sv_add_arena(nice_chunk, nice_chunk_size, 0);
+ nice_chunk = Nullch;
+ }
+ else
+ sv_add_arena(safemalloc(1008), 1008, 0);
return new_sv();
}
#endif
void
sv_report_used()
{
+ SV* sva;
SV* sv;
register SV* svend;
- for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) {
- svend = &sv[1008 / sizeof(SV)];
+ for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
+ sv = sva + 1;
+ svend = &sva[SvREFCNT(sva)];
while (sv < svend) {
if (SvTYPE(sv) != SVTYPEMASK) {
fprintf(stderr, "****\n");
void
sv_clean_objs()
{
+ SV* sva;
register SV* sv;
register SV* svend;
SV* rv;
- for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) {
- svend = &sv[1008 / sizeof(SV)];
+ for (sva = sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
+ sv = sva + 1;
+ svend = &sva[SvREFCNT(sva)];
while (sv < svend) {
if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
DEBUG_D((fprintf(stderr, "Cleaning object ref:\n "),
void
sv_clean_all()
{
+ SV* sva;
register SV* sv;
register SV* svend;
- for (sv = sv_arenaroot; sv; sv = (SV *) SvANY(sv)) {
- svend = &sv[1008 / sizeof(SV)];
+ for (sva = sv_arenaroot; sva; sva = (SV*) SvANY(sva)) {
+ sv = sva + 1;
+ svend = &sva[SvREFCNT(sva)];
while (sv < svend) {
if (SvTYPE(sv) != SVTYPEMASK) {
DEBUG_D((fprintf(stderr, "Cleaning loops:\n "), sv_dump(sv));)
}
}
+void
+sv_free_arenas()
+{
+ SV* sva;
+ SV* svanext;
+
+ /* Free arenas here, but be careful about fake ones. (We assume
+ contiguity of the fake ones with the corresponding real ones.) */
+
+ for (sva = sv_arenaroot; sva; sva = svanext) {
+ svanext = (SV*) SvANY(sva);
+ while (svanext && SvFAKE(svanext))
+ svanext = (SV*) SvANY(svanext);
+
+ if (!SvFAKE(sva))
+ Safefree(sva);
+ }
+}
+
static XPVIV*
new_xiv()
{
*d = '\0';
if (op)
- warn("Argument \"%s\" isn't numeric for %s", tmpbuf,
+ warn("Argument \"%s\" isn't numeric in %s", tmpbuf,
op_name[op->op_type]);
else
warn("Argument \"%s\" isn't numeric", tmpbuf);
if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) {
sv_unglob(dstr); /* so fake GLOB won't perpetuate */
- SvPOK_only(dstr);
+ sv_setpvn(dstr, "", 0);
+ (void)SvPOK_only(dstr);
dtype = SvTYPE(dstr);
}
case SVt_RV:
if (dtype < SVt_RV)
sv_upgrade(dstr, SVt_RV);
+ else if (dtype == SVt_PVGV &&
+ SvTYPE(SvRV(sstr)) == SVt_PVGV) {
+ sstr = SvRV(sstr);
+ goto glob_assign;
+ }
break;
case SVt_PV:
if (dtype < SVt_PV)
if (dtype < SVt_PVNV)
sv_upgrade(dstr, SVt_PVNV);
break;
+
+ case SVt_PVLV:
+ sv_upgrade(dstr, SVt_PVNV);
+ break;
+
+ case SVt_PVAV:
+ case SVt_PVHV:
+ case SVt_PVCV:
+ case SVt_PVIO:
+ if (op)
+ croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
+ op_name[op->op_type]);
+ else
+ croak("Bizarre copy of %s", sv_reftype(sstr, 0));
+ break;
+
case SVt_PVGV:
if (dtype <= SVt_PVGV) {
- if (dtype < SVt_PVGV) {
+ glob_assign:
+ if (dtype == SVt_PVGV)
+ GvFLAGS(sstr) |= GVf_IMPORTED;
+ else {
char *name = GvNAME(sstr);
STRLEN len = GvNAMELEN(sstr);
sv_upgrade(dstr, SVt_PVGV);
SvFAKE_on(dstr); /* can coerce to non-glob */
}
(void)SvOK_off(dstr);
- if (!GvAV(sstr))
- gv_AVadd(sstr);
- if (!GvHV(sstr))
- gv_HVadd(sstr);
- if (!GvIO(sstr))
- gv_IOadd(sstr);
if (GvGP(dstr))
gp_free(dstr);
GvGP(dstr) = gp_ref(GvGP(sstr));
SAVESPTR(GvCV(dstr));
else {
CV* cv = GvCV(dstr);
- dref = (SV*)cv;
- if (dowarn && cv && sref != dref &&
- !GvCVGEN((GV*)dstr) &&
- (CvROOT(cv) || CvXSUB(cv)) )
- warn("Subroutine %s redefined", GvENAME((GV*)dstr));
+ if (cv) {
+ dref = (SV*)cv;
+ if (dowarn && sref != dref &&
+ !GvCVGEN((GV*)dstr) &&
+ (CvROOT(cv) || CvXSUB(cv)) )
+ warn("Subroutine %s redefined",
+ GvENAME((GV*)dstr));
+ SvFAKE_on(cv);
+ }
}
- GvFLAGS(dstr) |= GVf_IMPORTED;
GvCV(dstr) = (CV*)sref;
break;
default:
GvSV(dstr) = sref;
break;
}
+ if (curcop->cop_stash != GvSTASH(dstr))
+ GvFLAGS(dstr) |= GVf_IMPORTED; /* crude */
if (dref)
SvREFCNT_dec(dref);
if (intro)
(void)SvOK_off(sv);
return;
}
- if (!SvUPGRADE(sv, SVt_PV))
+ if (SvTYPE(sv) >= SVt_PV) {
+ if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
+ sv_unglob(sv);
+ }
+ else if (!sv_upgrade(sv, SVt_PV))
return;
SvGROW(sv, len + 1);
Move(ptr,SvPVX(sv),len,char);
return;
}
len = strlen(ptr);
- if (!SvUPGRADE(sv, SVt_PV))
+ if (SvTYPE(sv) >= SVt_PV) {
+ if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
+ sv_unglob(sv);
+ }
+ else if (!sv_upgrade(sv, SVt_PV))
return;
SvGROW(sv, len + 1);
Move(ptr,SvPVX(sv),len+1,char);
junk = SvPV_force(sv, tlen);
SvGROW(sv, tlen + len + 1);
+ if (ptr == junk)
+ ptr = SvPVX(sv);
Move(ptr,SvPVX(sv)+tlen,len,char);
SvCUR(sv) += len;
*SvEND(sv) = '\0';
junk = SvPV_force(sv, tlen);
len = strlen(ptr);
SvGROW(sv, tlen + len + 1);
+ if (ptr == junk)
+ ptr = SvPVX(sv);
Move(ptr,SvPVX(sv)+tlen,len+1,char);
SvCUR(sv) += len;
(void)SvPOK_only(sv); /* validate pointer */
if (SvREADONLY(sv) && curcop != &compiling && !strchr("gB", how))
croak(no_modify);
- if (SvMAGICAL(sv)) {
+ if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
if (how == 't')
mg->mg_len |= 1;
case '.':
mg->mg_virtual = &vtbl_pos;
break;
- case '~': /* reserved for extensions but multiple extensions may clash */
+ case '~': /* 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:
croak("Don't know how to handle magic of type '%c'", how);
{
MAGIC* mg;
MAGIC** mgp;
- if (!SvMAGICAL(sv))
+ if (SvTYPE(sv) < SVt_PVMG)
return 0;
mgp = &SvMAGIC(sv);
for (mg = *mgp; mg; mg = *mgp) {
else
mgp = &mg->mg_moremagic;
}
- if (!SvMAGIC(sv)) {
+ if (!SvMAGICAL(sv) && !SvMAGIC(sv)) {
SvMAGICAL_off(sv);
SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
}
PUSHMARK(SP);
PUSHs(&ref);
PUTBACK;
- perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL);
+ perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
del_XRV(SvANY(&ref));
}
LEAVE;
}
+ else
+ SvREFCNT_dec(SvSTASH(sv));
if (SvOBJECT(sv)) {
SvOBJECT_off(sv); /* Curse the object. */
if (SvTYPE(sv) != SVt_PVIO)
--sv_objcount; /* XXX Might want something more general */
}
}
- if (SvMAGICAL(sv))
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
mg_free(sv);
switch (SvTYPE(sv)) {
case SVt_PVIO:
register FILE *fp;
I32 append;
{
- register char *bp; /* we're going to steal some values */
-#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
- register I32 cnt; /* from the stdio struct and put EVERYTHING */
- register STDCHAR *ptr; /* in the innermost loop into registers */
+ char *rsptr;
+ STRLEN rslen;
+ register STDCHAR rslast;
+ register STDCHAR *bp;
+ register I32 cnt;
+ I32 i;
+
+#ifdef FAST_SV_GETS
+ /*
+ * We're going to steal some values from the stdio struct
+ * and put EVERYTHING in the innermost loop into registers.
+ */
+ register STDCHAR *ptr;
STRLEN bpx;
I32 shortbuffered;
#endif
- register I32 newline = rschar;/* (assuming >= 6 registers) */
- I32 i;
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv) && curcop != &compiling)
}
if (!SvUPGRADE(sv, SVt_PV))
return 0;
- if (rspara) { /* have to do this both before and after */
+
+ if (RsSNARF(rs)) {
+ rsptr = NULL;
+ rslen = 0;
+ }
+ else if (RsPARA(rs)) {
+ rsptr = "\n\n";
+ rslen = 2;
+ }
+ else
+ rsptr = SvPV(rs, rslen);
+ rslast = rslen ? rsptr[rslen - 1] : '\0';
+
+ if (RsPARA(rs)) { /* have to do this both before and after */
do { /* to make sure file boundaries work right */
if (feof(fp))
return 0;
}
} while (i != EOF);
}
-#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE)
+
+#ifdef FAST_SV_GETS
+
/* Here is some breathtakingly efficient cheating */
+
cnt = FILE_cnt(fp); /* get count into register */
(void)SvPOK_only(sv); /* validate pointer */
if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
}
else
shortbuffered = 0;
- bp = SvPVX(sv) + append; /* move these two too to registers */
+ bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
ptr = FILE_ptr(fp);
for (;;) {
screamer:
if (cnt > 0) {
- while (--cnt >= 0) { /* this */ /* eat */
- if ((*bp++ = *ptr++) == newline) /* really */ /* dust */
- goto thats_all_folks; /* screams */ /* sed :-) */
+ if (rslen) {
+ while (--cnt >= 0) { /* this | eat */
+ if ((*bp++ = *ptr++) == rslast) /* really | dust */
+ goto thats_all_folks; /* screams | sed :-) */
+ }
+ }
+ else {
+ memcpy((char*)bp, (char*)ptr, cnt); /* this | eat */
+ bp += cnt; /* screams | dust */
+ ptr += cnt; /* louder | sed :-) */
}
}
if (shortbuffered) { /* oh well, must extend */
cnt = shortbuffered;
shortbuffered = 0;
- bpx = bp - SvPVX(sv); /* prepare for possible relocation */
+ bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
SvCUR_set(sv, bpx);
SvGROW(sv, SvLEN(sv) + append + cnt + 2);
- bp = SvPVX(sv) + bpx; /* reconstitute our pointer */
+ bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
continue;
}
if (i == EOF) /* all done for ever? */
goto thats_really_all_folks;
- bpx = bp - SvPVX(sv); /* prepare for possible relocation */
+ bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
SvCUR_set(sv, bpx);
SvGROW(sv, bpx + cnt + 2);
- bp = SvPVX(sv) + bpx; /* reconstitute our pointer */
+ bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
+
+ *bp++ = i; /* store character from _filbuf */
- if (i == newline) { /* all done for now? */
- *bp++ = i;
+ if (rslen && (STDCHAR)i == rslast) /* all done for now? */
goto thats_all_folks;
- }
- *bp++ = i; /* now go back to screaming loop */
}
thats_all_folks:
- if (rslen > 1 && (bp - SvPVX(sv) < rslen || bcmp(bp - rslen, rs, rslen)))
+ if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
+ bcmp((char*)bp - rslen, rsptr, rslen))
goto screamer; /* go back to the fray */
thats_really_all_folks:
if (shortbuffered)
FILE_cnt(fp) = cnt; /* put these back or we're in trouble */
FILE_ptr(fp) = ptr;
*bp = '\0';
- SvCUR_set(sv, bp - SvPVX(sv)); /* set length */
+ SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
+
+#else /* SV_FAST_GETS */
-#else /* USE_STDIO_PTR && STDIO_PTR_LVALUE && STDIO_CNT_LVALUE */
/*The big, slow, and stupid way */
+
{
- char buf[8192];
- register char * bpe = buf + sizeof(buf) - 3;
+ STDCHAR buf[8192];
screamer:
- bp = buf;
- while ((i = getc(fp)) != EOF && (*bp++ = i) != newline && bp < bpe) ;
+ if (rslen) {
+ register STDCHAR *bpe = buf + sizeof(buf);
+ bp = buf;
+ while ((i = getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
+ ; /* keep reading */
+ cnt = bp - buf;
+ }
+ else {
+ cnt = fread((char*)buf, 1, sizeof(buf), fp);
+ i = (cnt == EOF) ? EOF : (U8)buf[cnt - 1];
+ }
if (append)
- sv_catpvn(sv, buf, bp - buf);
+ sv_catpvn(sv, buf, cnt);
else
- sv_setpvn(sv, buf, bp - buf);
- if (i != EOF /* joy */
- &&
- (i != newline
- ||
- (rslen > 1
- &&
- (SvCUR(sv) < rslen
- ||
- bcmp(SvPVX(sv) + SvCUR(sv) - rslen, rs, rslen)
- )
- )
- )
- )
+ sv_setpvn(sv, buf, cnt);
+
+ if (i != EOF && /* joy */
+ (!rslen ||
+ SvCUR(sv) < rslen ||
+ bcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
{
append = -1;
goto screamer;
}
}
-#endif /* USE_STDIO_PTR && STDIO_PTR_LVALUE && STDIO_CNT_LVALUE */
+#endif /* SV_FAST_GETS */
- if (rspara) {
- while (i != EOF) {
+ if (RsPARA(rs)) { /* have to do this both before and after */
+ while (i != EOF) { /* to make sure file boundaries work right */
i = getc(fp);
if (i != '\n') {
ungetc(i,fp);
}
}
}
- return SvCUR(sv) - append ? SvPVX(sv) : Nullch;
+
+ return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
}
void
return;
}
if (!(flags & SVp_POK) || !*SvPVX(sv)) {
- sv_upgrade(sv, SVt_NV);
+ if ((flags & SVTYPEMASK) < SVt_PVNV)
+ sv_upgrade(sv, SVt_NV);
SvNVX(sv) = 1.0;
(void)SvNOK_only(sv);
return;
return;
}
if (!(flags & SVp_POK)) {
- sv_upgrade(sv, SVt_NV);
+ if ((flags & SVTYPEMASK) < SVt_PVNV)
+ sv_upgrade(sv, SVt_NV);
SvNVX(sv) = -1.0;
(void)SvNOK_only(sv);
return;
*st = GvESTASH(gv);
fix_gv:
if (lref && !GvCV(gv)) {
+ SV *tmpsv;
ENTER;
- sv = NEWSV(704,0);
- gv_efullname(sv, gv);
+ tmpsv = NEWSV(704,0);
+ gv_efullname(tmpsv, gv);
newSUB(start_subparse(),
- newSVOP(OP_CONST, 0, sv),
+ newSVOP(OP_CONST, 0, tmpsv),
+ Nullop,
Nullop);
LEAVE;
+ if (!GvCV(gv))
+ croak("Unable to create sub named \"%s\"", SvPV(sv,na));
}
return GvCV(gv);
}
}
else {
if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
- if (SvTYPE(sv) == SVt_PVGV && SvFAKE(sv)) {
+ if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) {
sv_unglob(sv);
- s = SvPVX(sv);
- *lp = SvCUR(sv);
- }
+ s = SvPVX(sv);
+ *lp = SvCUR(sv);
+ }
else
croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
op_name[op->op_type]);
}
- else
- s = sv_2pv(sv, lp);
+ else
+ s = sv_2pv(sv, lp);
if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
STRLEN len = *lp;
SvRV(sv) = 0;
SvROK_off(sv);
- if (SvREFCNT(rv) == 1)
- sv_2mortal(rv);
+ if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
+ SvREFCNT_dec(rv);
else
- SvREFCNT_dec(rv);
+ sv_2mortal(rv); /* Schedule for freeing later */
}
#ifdef DEBUGGING
fprintf(stderr, " FILL = %ld\n", (long)AvFILL(sv));
fprintf(stderr, " MAX = %ld\n", (long)AvMAX(sv));
fprintf(stderr, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
- if (AvREAL(sv))
- fprintf(stderr, " FLAGS = (REAL)\n");
- else
- fprintf(stderr, " FLAGS = ()\n");
+ flags = AvFLAGS(sv);
+ d = tmpbuf;
+ if (flags & AVf_REAL) strcat(d, "REAL,");
+ if (flags & AVf_REIFY) strcat(d, "REIFY,");
+ if (flags & AVf_REUSED) strcat(d, "REUSED,");
+ if (*d)
+ d[strlen(d)-1] = '\0';
+ fprintf(stderr, " FLAGS = (%s)\n", d);
break;
case SVt_PVHV:
fprintf(stderr, " ARRAY = 0x%lx\n",(long)HvARRAY(sv));