}
#endif
+static bool in_clean_objs = FALSE;
+
void
sv_clean_objs()
{
+ in_clean_objs = TRUE;
#ifndef DISABLE_DESTRUCTOR_KLUDGE
visit(do_clean_named_objs);
#endif
visit(do_clean_objs);
+ in_clean_objs = FALSE;
}
static void
SvREFCNT_dec(sv);
}
-static int in_clean_all = 0;
+static bool in_clean_all = FALSE;
void
sv_clean_all()
{
- in_clean_all = 1;
+ in_clean_all = TRUE;
visit(do_clean_all);
- in_clean_all = 0;
+ in_clean_all = FALSE;
}
void
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));
- SvFAKE_on(cv);
}
}
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);
void
sv_setpvn(sv,ptr,len)
register SV *sv;
-register char *ptr;
+register const char *ptr;
register STRLEN len;
{
assert(len >= 0); /* STRLEN is probably unsigned, so this may
void
sv_setpv(sv,ptr)
register SV *sv;
-register char *ptr;
+register const char *ptr;
{
register STRLEN len;
mg->mg_virtual = &vtbl_substr;
break;
case 'y':
- mg->mg_virtual = &vtbl_vivary;
+ mg->mg_virtual = &vtbl_itervar;
break;
case '*':
mg->mg_virtual = &vtbl_glob;
}
SvREFCNT(sv) = 0;
sv_clear(sv);
+ assert(!SvREFCNT(sv));
StructCopy(nsv,sv,SV);
SvREFCNT(sv) = refcnt;
SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
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
--sv_objcount; /* XXX Might want something more general */
}
if (SvREFCNT(sv)) {
- SV *ret;
+ SV *ret;
if ( perldb
&& (ret = perl_get_sv("DB::ret", FALSE))
&& SvROK(ret) && SvRV(ret) == sv && SvREFCNT(sv) == 1) {
SvRV(ret) = 0;
SvROK_off(ret);
SvREFCNT(sv) = 0;
- } else {
- croak("DESTROY created new reference to dead object");
+ }
+ else {
+ if (in_clean_objs)
+ croak("DESTROY created new reference to dead object");
+ /* DESTROY gave object new lease on life */
+ return;
}
}
}
}
#endif
sv_clear(sv);
- del_SV(sv);
+ if (! SvREFCNT(sv))
+ del_SV(sv);
}
STRLEN
}
#ifdef USE_LOCALE_COLLATE
-
+/*
+ * Any scalar variable may carry an 'o' magic that contains the
+ * scalar data of the variable transformed to such a format that
+ * a normal memory comparison can be used to compare the data
+ * according to the locale settings.
+ */
char *
sv_collxfrm(sv, nxp)
SV *sv;
STRLEN *nxp;
{
- /* Any scalar variable may carry an 'o' magic that contains the
- * scalar data of the variable transformed to such a format that
- * a normal memory comparison can be used to compare the data
- * according to the locale settings. */
-
- MAGIC *mg = NULL;
+ MAGIC *mg;
- if (SvMAGICAL(sv)) {
- mg = mg_find(sv, 'o');
- if (mg && *(U32*)mg->mg_ptr != collation_ix)
- mg = NULL;
- }
-
- if (! mg) {
+ mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : NULL;
+ if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) {
char *s, *xf;
STRLEN len, xlen;
+ if (mg)
+ Safefree(mg->mg_ptr);
s = SvPV(sv, len);
if ((xf = mem_collxfrm(s, len, &xlen))) {
- sv_magic(sv, 0, 'o', 0, 0);
- if ((mg = mg_find(sv, 'o'))) {
- mg->mg_ptr = xf;
- mg->mg_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');
+ assert(mg);
+ }
+ mg->mg_ptr = xf;
+ mg->mg_len = xlen;
+ }
+ else {
+ if (mg) {
+ mg->mg_ptr = NULL;
+ mg->mg_len = -1;
}
}
}
-
- if (mg) {
+ if (mg && mg->mg_ptr) {
*nxp = mg->mg_len;
return mg->mg_ptr + sizeof(collation_ix);
}
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;
sv_untaint(sv)
SV *sv;
{
- if (SvMAGICAL(sv)) {
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC *mg = mg_find(sv, 't');
if (mg)
mg->mg_len &= ~1;
sv_tainted(sv)
SV *sv;
{
- if (SvMAGICAL(sv)) {
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
MAGIC *mg = mg_find(sv, 't');
if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
return TRUE;
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));
https://perl5.git.perl.org / perl5.git / blobdiff