char tmpbuf[64];
char *d = tmpbuf;
char *s;
- int i;
+ char *limit = tmpbuf + sizeof(tmpbuf) - 8;
+ /* each *s can expand to 4 chars + "...\0",
+ i.e. need room for 8 chars */
- for (s = SvPVX(sv), i = 50; *s && i; s++,i--) {
+ for (s = SvPVX(sv); *s && d < limit; s++) {
int ch = *s & 0xFF;
if (ch & 128 && !isPRINT_LC(ch)) {
*d++ = 'M';
switch (SvTYPE(sv)) {
case SVt_NULL:
sv_upgrade(sv, SVt_IV);
- return SvIVX(sv);
+ break;
case SVt_PV:
sv_upgrade(sv, SVt_PVIV);
break;
switch (SvTYPE(sv)) {
case SVt_NULL:
sv_upgrade(sv, SVt_IV);
- return SvUVX(sv);
+ break;
case SVt_PV:
sv_upgrade(sv, SVt_PVIV);
break;
register char *s;
register char *send;
register char *sbegin;
- I32 numtype = 1;
+ I32 numtype;
STRLEN len;
if (SvPOK(sv)) {
s = sbegin;
while (isSPACE(*s))
s++;
- if (s >= send)
- return 0;
if (*s == '+' || *s == '-')
s++;
- while (isDIGIT(*s))
- s++;
- if (s == send)
- return numtype;
- if (*s == '.') {
- numtype = 1;
- s++;
+
+ /* next must be digit or '.' */
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ if (*s == '.') {
+ s++;
+ while (isDIGIT(*s)) /* optional digits after "." */
+ s++;
+ }
}
- else if (s == SvPVX(sv))
- return 0;
- while (isDIGIT(*s))
- s++;
- if (s == send)
- return numtype;
+ else if (*s == '.') {
+ s++;
+ /* no digits before '.' means we need digits after it */
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ }
+ else
+ return 0;
+ }
+ else
+ return 0;
+
+ /*
+ * we return 1 if the number can be converted to _integer_ with atol()
+ * and 2 if you need (int)atof().
+ */
+ numtype = 1;
+
+ /* we can have an optional exponent part */
if (*s == 'e' || *s == 'E') {
numtype = 2;
s++;
if (*s == '+' || *s == '-')
s++;
- while (isDIGIT(*s))
- s++;
+ if (isDIGIT(*s)) {
+ do {
+ s++;
+ } while (isDIGIT(*s));
+ }
+ else
+ return 0;
}
while (isSPACE(*s))
s++;
GvGP(dstr)->gp_refcnt--;
GvINTRO_off(dstr); /* one-shot flag */
Newz(602,gp, 1, GP);
- GvGP(dstr) = gp;
- GvREFCNT(dstr) = 1;
+ GvGP(dstr) = gp_ref(gp);
GvSV(dstr) = NEWSV(72,0);
GvLINE(dstr) = curcop->cop_line;
GvEGV(dstr) = (GV*)dstr;
GvIMPORTED_HV_on(dstr);
break;
case SVt_PVCV:
- if (intro)
+ if (intro) {
+ if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
+ SvREFCNT_dec(GvCV(dstr));
+ GvCV(dstr) = Nullcv;
+ GvCVGEN(dstr) = 0;
+ }
SAVESPTR(GvCV(dstr));
+ }
else {
CV* cv = GvCV(dstr);
if (cv) {
(CvROOT(cv) || CvXSUB(cv)) )
warn("Subroutine %s redefined",
GvENAME((GV*)dstr));
- if (SvREFCNT(cv) == 1)
- SvFAKE_on(cv);
}
}
- sub_generation++;
if (GvCV(dstr) != (CV*)sref) {
GvCV(dstr) = (CV*)sref;
GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
+ sub_generation++;
}
if (curcop->cop_stash != GvSTASH(dstr))
GvIMPORTED_CV_on(dstr);
assert(SvREFCNT(sv) == 0);
if (SvOBJECT(sv)) {
- dSP;
- GV* destructor;
-
if (defstash) { /* Still have a symbol table? */
- destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
+ dSP;
+ GV* destructor;
ENTER;
SAVEFREESV(SvSTASH(sv));
- if (destructor && GvCV(destructor)) {
+
+ destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
+ if (destructor) {
SV ref;
Zero(&ref, 1, SV);
sv_upgrade(&ref, SVt_RV);
SvRV(&ref) = SvREFCNT_inc(sv);
SvROK_on(&ref);
+ SvREFCNT(&ref) = 1; /* Fake, but otherwise
+ creating+destructing a ref
+ leads to disaster. */
EXTEND(SP, 2);
PUSHMARK(SP);
PUSHs(&ref);
PUTBACK;
- perl_call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
+ perl_call_sv((SV*)GvCV(destructor),
+ G_DISCARD|G_EVAL|G_KEEPERR);
del_XRV(SvANY(&ref));
SvREFCNT(sv)--;
}
+
LEAVE;
}
else
Safefree(mg->mg_ptr);
s = SvPV(sv, len);
if ((xf = mem_collxfrm(s, len, &xlen))) {
+ if (SvREADONLY(sv)) {
+ SAVEFREEPV(xf);
+ *nxp = xlen;
+ return xf;
+ }
if (! mg) {
sv_magic(sv, 0, 'o', 0, 0);
mg = mg_find(sv, 'o');
mg->mg_len = xlen;
}
else {
- mg->mg_ptr = NULL;
- mg->mg_len = -1;
+ if (mg) {
+ mg->mg_ptr = NULL;
+ mg->mg_len = -1;
+ }
}
}
if (mg && mg->mg_ptr) {
PerlIO_get_ptr(fp), PerlIO_get_cnt(fp),
PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0));
/* This used to call 'filbuf' in stdio form, but as that behaves like
- getc when cnt <= 0 we use PerlIO_getc here to avoid another
- abstraction. This may also avoid issues with different named
- 'filbuf' equivalents, though Configure tries to handle them now
- anyway.
- */
+ getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
+ another abstraction. */
i = PerlIO_getc(fp); /* get more characters */
DEBUG_P(PerlIO_printf(Perl_debug_log,
"Screamer: post: FILE * thinks ptr=%d, cnt=%d, base=%d\n",
(void)SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
SvCUR_set(sv, 0);
- SvTAINT(sv);
if (SvPVX(sv) != Nullch)
*SvPVX(sv) = '\0';
+ SvTAINT(sv);
}
if (GvAV(gv)) {
av_clear(GvAV(gv));
}
- if (GvHV(gv)) {
- if (HvNAME(GvHV(gv)))
- continue;
+ if (GvHV(gv) && !HvNAME(GvHV(gv))) {
hv_clear(GvHV(gv));
#ifndef VMS /* VMS has no environ array */
if (gv == envgv)
return Nullcv;
*st = GvESTASH(gv);
fix_gv:
- if (lref && !GvCV(gv)) {
+ if (lref && !GvCVu(gv)) {
SV *tmpsv;
ENTER;
tmpsv = NEWSV(704,0);
gv_efullname3(tmpsv, gv, Nullch);
- newSUB(start_subparse(),
+ newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, tmpsv),
Nullop,
Nullop);
LEAVE;
- if (!GvCV(gv))
+ if (!GvCVu(gv))
croak("Unable to create sub named \"%s\"", SvPV(sv,na));
}
- return GvCV(gv);
+ return GvCVu(gv);
}
}
if (SvFLAGS(ref) & (SVs_OBJECT|SVf_READONLY)) {
if (SvREADONLY(ref))
croak(no_modify);
- if (SvOBJECT(ref) && SvTYPE(ref) != SVt_PVIO)
- --sv_objcount;
+ if (SvOBJECT(ref)) {
+ if (SvTYPE(ref) != SVt_PVIO)
+ --sv_objcount;
+ SvREFCNT_dec(SvSTASH(ref));
+ }
}
SvOBJECT_on(ref);
- ++sv_objcount;
+ if (SvTYPE(ref) != SVt_PVIO)
+ ++sv_objcount;
(void)SvUPGRADE(ref, SVt_PVMG);
SvSTASH(ref) = (HV*)SvREFCNT_inc(stash);
#ifdef OVERLOAD
- SvAMAGIC_off(sv);
- if (Gv_AMG(stash)) {
- SvAMAGIC_on(sv);
- }
+ if (Gv_AMG(stash))
+ SvAMAGIC_on(sv);
+ else
+ SvAMAGIC_off(sv);
#endif /* OVERLOAD */
return sv;
switch (type) {
case SVt_PVCV:
- if (CvANON(sv)) strcat(d, "ANON,");
- if (CvCLONE(sv)) strcat(d, "CLONE,");
- if (CvCLONED(sv)) strcat(d, "CLONED,");
+ case SVt_PVFM:
+ if (CvANON(sv)) strcat(d, "ANON,");
+ if (CvUNIQUE(sv)) strcat(d, "UNIQUE,");
+ if (CvCLONE(sv)) strcat(d, "CLONE,");
+ if (CvCLONED(sv)) strcat(d, "CLONED,");
+ if (CvNODEBUG(sv)) strcat(d, "NODEBUG,");
break;
case SVt_PVHV:
if (HvSHAREKEYS(sv)) strcat(d, "SHAREKEYS,");
strcat(d, " ),");
}
}
-#ifdef OVERLOAD
- if (flags & SVpgv_AM) strcat(d, "withOVERLOAD,");
-#endif /* OVERLOAD */
}
d += strlen(d);
if (HvNAME(sv))
PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv));
break;
- case SVt_PVFM:
case SVt_PVCV:
if (SvPOK(sv))
PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,na));
+ /* FALL THROUGH */
+ case SVt_PVFM:
PerlIO_printf(Perl_debug_log, " STASH = 0x%lx\n", (long)CvSTASH(sv));
PerlIO_printf(Perl_debug_log, " START = 0x%lx\n", (long)CvSTART(sv));
PerlIO_printf(Perl_debug_log, " ROOT = 0x%lx\n", (long)CvROOT(sv));