# define FAST_SV_GETS
#endif
+static IV asIV _((SV* sv));
+static UV asUV _((SV* sv));
static SV *more_sv _((void));
static XPVIV *more_xiv _((void));
static XPVNV *more_xnv _((void));
}
#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
if (!SvFAKE(sva))
Safefree((void *)sva);
}
+
+ sv_arenaroot = 0;
+ sv_root = 0;
}
static XPVIV*
sprintf(t,"(\"%.127s\")",SvPVX(sv));
}
else if (SvNOKp(sv)) {
- NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
sprintf(t,"(%g)",SvNVX(sv));
}
else if (SvIOKp(sv))
else
return (IV) U_V(SvNVX(sv));
}
- if (SvPOKp(sv) && SvLEN(sv)) {
- if (dowarn && !looks_like_number(sv))
- not_a_number(sv);
- return (IV)atol(SvPVX(sv));
- }
- if (!SvROK(sv)) {
- return 0;
- }
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asIV(sv);
+ if (!SvROK(sv))
+ return 0;
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
else
return (IV) U_V(SvNVX(sv));
}
- if (SvPOKp(sv) && SvLEN(sv)) {
- if (dowarn && !looks_like_number(sv))
- not_a_number(sv);
- return (IV)atol(SvPVX(sv));
- }
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asIV(sv);
if (dowarn)
warn(warn_uninit);
return 0;
if (SvNVX(sv) < 0.0)
SvIVX(sv) = I_V(SvNVX(sv));
else
- SvIVX(sv) = (IV) U_V(SvNVX(sv));
+ SvUVX(sv) = U_V(SvNVX(sv));
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- if (dowarn && !looks_like_number(sv))
- not_a_number(sv);
(void)SvIOK_on(sv);
- SvIVX(sv) = (IV)atol(SvPVX(sv));
+ SvIVX(sv) = asIV(sv);
}
else {
if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
return SvIVX(sv);
}
+UV
+sv_2uv(sv)
+register SV *sv;
+{
+ if (!sv)
+ return 0;
+ if (SvGMAGICAL(sv)) {
+ mg_get(sv);
+ if (SvIOKp(sv))
+ return SvUVX(sv);
+ if (SvNOKp(sv))
+ return U_V(SvNVX(sv));
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asUV(sv);
+ if (!SvROK(sv))
+ return 0;
+ }
+ if (SvTHINKFIRST(sv)) {
+ if (SvROK(sv)) {
+#ifdef OVERLOAD
+ SV* tmpstr;
+ if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
+ return SvUV(tmpstr);
+#endif /* OVERLOAD */
+ return (UV)SvRV(sv);
+ }
+ if (SvREADONLY(sv)) {
+ if (SvNOKp(sv)) {
+ return U_V(SvNVX(sv));
+ }
+ if (SvPOKp(sv) && SvLEN(sv))
+ return asUV(sv);
+ if (dowarn)
+ warn(warn_uninit);
+ return 0;
+ }
+ }
+ switch (SvTYPE(sv)) {
+ case SVt_NULL:
+ sv_upgrade(sv, SVt_IV);
+ return SvUVX(sv);
+ case SVt_PV:
+ sv_upgrade(sv, SVt_PVIV);
+ break;
+ case SVt_NV:
+ sv_upgrade(sv, SVt_PVNV);
+ break;
+ }
+ if (SvNOKp(sv)) {
+ (void)SvIOK_on(sv);
+ SvUVX(sv) = U_V(SvNVX(sv));
+ }
+ else if (SvPOKp(sv) && SvLEN(sv)) {
+ (void)SvIOK_on(sv);
+ SvUVX(sv) = asUV(sv);
+ }
+ else {
+ if (dowarn && !localizing && !(SvFLAGS(sv) & SVs_PADTMP))
+ warn(warn_uninit);
+ return 0;
+ }
+ DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
+ (unsigned long)sv,SvUVX(sv)));
+ return SvUVX(sv);
+}
+
double
sv_2nv(sv)
register SV *sv;
if (SvPOKp(sv) && SvLEN(sv)) {
if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
- NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
if (SvIOKp(sv))
if (SvPOKp(sv) && SvLEN(sv)) {
if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
- NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
if (SvIOKp(sv))
sv_upgrade(sv, SVt_PVNV);
else
sv_upgrade(sv, SVt_NV);
- DEBUG_c(NUMERIC_STANDARD());
+ DEBUG_c(SET_NUMERIC_STANDARD());
DEBUG_c(PerlIO_printf(Perl_debug_log,
"0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
}
else if (SvPOKp(sv) && SvLEN(sv)) {
if (dowarn && !SvIOKp(sv) && !looks_like_number(sv))
not_a_number(sv);
- NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
SvNVX(sv) = atof(SvPVX(sv));
}
else {
return 0.0;
}
SvNOK_on(sv);
- DEBUG_c(NUMERIC_STANDARD());
+ DEBUG_c(SET_NUMERIC_STANDARD());
DEBUG_c(PerlIO_printf(Perl_debug_log,
"0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
return SvNVX(sv);
}
+static IV
+asIV(sv)
+SV *sv;
+{
+ I32 numtype = looks_like_number(sv);
+ double d;
+
+ if (numtype == 1)
+ return atol(SvPVX(sv));
+ if (!numtype && dowarn)
+ not_a_number(sv);
+ SET_NUMERIC_STANDARD();
+ d = atof(SvPVX(sv));
+ if (d < 0.0)
+ return I_V(d);
+ else
+ return (IV) U_V(d);
+}
+
+static UV
+asUV(sv)
+SV *sv;
+{
+ I32 numtype = looks_like_number(sv);
+
+ if (numtype == 1)
+ return atol(SvPVX(sv));
+ if (!numtype && dowarn)
+ not_a_number(sv);
+ SET_NUMERIC_STANDARD();
+ return U_V(atof(SvPVX(sv)));
+}
+
+I32
+looks_like_number(sv)
+SV *sv;
+{
+ register char *s;
+ register char *send;
+ register char *sbegin;
+ I32 numtype = 1;
+ STRLEN len;
+
+ if (SvPOK(sv)) {
+ sbegin = SvPVX(sv);
+ len = SvCUR(sv);
+ }
+ else if (SvPOKp(sv))
+ sbegin = SvPV(sv, len);
+ else
+ return 1;
+ send = sbegin + len;
+
+ 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++;
+ }
+ else if (s == SvPVX(sv))
+ return 0;
+ while (isDIGIT(*s))
+ s++;
+ if (s == send)
+ return numtype;
+ if (*s == 'e' || *s == 'E') {
+ numtype = 2;
+ s++;
+ if (*s == '+' || *s == '-')
+ s++;
+ while (isDIGIT(*s))
+ s++;
+ }
+ while (isSPACE(*s))
+ s++;
+ if (s >= send)
+ return numtype;
+ if (len == 10 && memEQ(sbegin, "0 but true", 10))
+ return 1;
+ return 0;
+}
+
char *
sv_2pv(sv, lp)
register SV *sv;
goto tokensave;
}
if (SvNOKp(sv)) {
- NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
goto tokensave;
}
case SVt_PVCV: s = "CODE"; break;
case SVt_PVGV: s = "GLOB"; break;
case SVt_PVFM: s = "FORMATLINE"; break;
- case SVt_PVIO: s = "FILEHANDLE"; break;
+ case SVt_PVIO: s = "IO"; break;
default: s = "UNKNOWN"; break;
}
if (SvOBJECT(sv))
}
if (SvREADONLY(sv)) {
if (SvNOKp(sv)) {
- NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, tokenbuf);
goto tokensave;
}
else
#endif /*apollo*/
{
- NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, s);
}
errno = olderrno;
(void)SvOK_off(dstr);
return;
case SVt_IV:
- if (dtype <= SVt_PV) {
+ if (dtype != SVt_IV && dtype < SVt_PVIV) {
if (dtype < SVt_IV)
sv_upgrade(dstr, SVt_IV);
else if (dtype == SVt_NV)
sv_upgrade(dstr, SVt_PVNV);
- else if (dtype <= SVt_PV)
+ else
sv_upgrade(dstr, SVt_PVIV);
}
break;
case SVt_NV:
- if (dtype <= SVt_PVIV) {
+ if (dtype != SVt_NV && dtype < SVt_PVNV) {
if (dtype < SVt_NV)
sv_upgrade(dstr, SVt_NV);
- else if (dtype == SVt_PVIV)
- sv_upgrade(dstr, SVt_PVNV);
- else if (dtype <= SVt_PV)
+ else
sv_upgrade(dstr, SVt_PVNV);
}
break;
(CvROOT(cv) || CvXSUB(cv)) )
warn("Subroutine %s redefined",
GvENAME((GV*)dstr));
- SvFAKE_on(cv);
+ 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);
}
if (curcop->cop_stash != GvSTASH(dstr))
* has to be allocated and SvPVX(sstr) has to be freed.
*/
- if ((SvTEMP(sstr) || SvPADTMP(sstr)) && /* slated for free anyway? */
+ if (SvTEMP(sstr) && /* slated for free anyway? */
!(sflags & SVf_OOK)) /* and not involved in OOK hack? */
{
if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
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;
case 'l':
mg->mg_virtual = &vtbl_dbline;
break;
-#ifdef HAS_STRXFRM
+#ifdef USE_LOCALE_COLLATE
case 'o':
mg->mg_virtual = &vtbl_collxfrm;
break;
-#endif
+#endif /* USE_LOCALE_COLLATE */
case 'P':
mg->mg_virtual = &vtbl_pack;
break;
case 'x':
mg->mg_virtual = &vtbl_substr;
break;
+ case 'y':
+ mg->mg_virtual = &vtbl_itervar;
+ break;
case '*':
mg->mg_virtual = &vtbl_glob;
break;
}
SvREFCNT(sv) = 0;
sv_clear(sv);
+ assert(!SvREFCNT(sv));
StructCopy(nsv,sv,SV);
SvREFCNT(sv) = refcnt;
SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
--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("panic: dangling references in DESTROY");
+ }
+ else {
+ if (in_clean_objs)
+ croak("DESTROY created new reference to dead object");
+ /* DESTROY gave object new lease on life */
+ return;
}
}
}
mg_free(sv);
switch (SvTYPE(sv)) {
case SVt_PVIO:
- io_close((IO*)sv);
+ if (IoIFP(sv) != PerlIO_stdin() &&
+ IoIFP(sv) != PerlIO_stdout() &&
+ IoIFP(sv) != PerlIO_stderr())
+ io_close((IO*)sv);
Safefree(IoTOP_NAME(sv));
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
}
#endif
sv_clear(sv);
- del_SV(sv);
+ if (! SvREFCNT(sv))
+ del_SV(sv);
}
STRLEN
if (cur1 != cur2)
return 0;
- return !memcmp(pv1, pv2, cur1);
+ return memEQ(pv1, pv2, cur1);
}
I32
register SV *sv1;
register SV *sv2;
{
-#ifdef LC_COLLATE
+#ifdef USE_LOCALE_COLLATE
char *pv1, *pv2;
STRLEN len1, len2;
raw_compare:
/* FALL THROUGH */
-#endif /* LC_COLLATE */
+#endif /* USE_LOCALE_COLLATE */
return sv_cmp(sv1, sv2);
}
-#ifdef LC_COLLATE
-
+#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 memcmp() can be used to compare the data according
- * to the locale settings. */
-
- MAGIC *mg = NULL;
-
- if (SvMAGICAL(sv)) {
- mg = mg_find(sv, 'o');
- if (mg && *(U32*)mg->mg_ptr != collation_ix)
- mg = NULL;
- }
+ MAGIC *mg;
- 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 (! mg) {
+ sv_magic(sv, 0, 'o', 0, 0);
+ mg = mg_find(sv, 'o');
+ assert(mg);
}
+ mg->mg_ptr = xf;
+ mg->mg_len = xlen;
+ }
+ else {
+ 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);
}
}
}
-#endif /* LC_COLLATE */
+#endif /* USE_LOCALE_COLLATE */
char *
sv_gets(sv,fp,append)
}
if (!SvUPGRADE(sv, SVt_PV))
return 0;
+ SvSCREAM_off(sv);
if (RsSNARF(rs)) {
rsptr = NULL;
}
}
else {
- memcpy((char*)bp, (char*)ptr, cnt); /* this | eat */
+ Copy(ptr, bp, cnt, char); /* this | eat */
bp += cnt; /* screams | dust */
ptr += cnt; /* louder | sed :-) */
cnt = 0;
thats_all_folks:
if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
- memcmp((char*)bp - rslen, rsptr, rslen))
+ memNE((char*)bp - rslen, rsptr, rslen))
goto screamer; /* go back to the fray */
thats_really_all_folks:
if (shortbuffered)
if (i != EOF && /* joy */
(!rslen ||
SvCUR(sv) < rslen ||
- memcmp(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
+ memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
{
append = -1;
goto screamer2;
while (isALPHA(*d)) d++;
while (isDIGIT(*d)) d++;
if (*d) {
- NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
return;
}
(void)SvNOK_only(sv);
return;
}
- NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
}
return sv;
}
+#ifdef CRIPPLED_CC
+SV *
+newRV_noinc(ref)
+SV *ref;
+{
+ register SV *sv;
+
+ sv = newRV(ref);
+ SvREFCNT_dec(ref);
+ return sv;
+}
+#endif /* CRIPPLED_CC */
+
/* make an exact duplicate of old */
SV *
register SV *old;
{
register SV *sv;
- U32 oflags;
if (!old)
return Nullsv;
SvANY(sv) = 0;
SvREFCNT(sv) = 1;
SvFLAGS(sv) = 0;
- oflags = SvFLAGS(old) & (SVs_TEMP|SVs_PADTMP);
- if (oflags) {
- SvFLAGS(old) &= ~(SVs_TEMP|SVs_PADTMP);
+ if (SvTEMP(old)) {
+ SvTEMP_off(old);
sv_setsv(sv,old);
- SvFLAGS(old) |= oflags;
+ SvTEMP_on(old);
}
else
sv_setsv(sv,old);
}
}
}
-#endif /* SvTRUE */
+#endif /* !SvTRUE */
#ifndef SvIV
-IV SvIV(Sv)
-register SV *Sv;
+IV
+SvIV(sv)
+register SV *sv;
{
- if (SvIOK(Sv))
- return SvIVX(Sv);
- return sv_2iv(Sv);
+ if (SvIOK(sv))
+ return SvIVX(sv);
+ return sv_2iv(sv);
}
-#endif /* SvIV */
+#endif /* !SvIV */
+#ifndef SvUV
+UV
+SvUV(sv)
+register SV *sv;
+{
+ if (SvIOK(sv))
+ return SvUVX(sv);
+ return sv_2uv(sv);
+}
+#endif /* !SvUV */
#ifndef SvNV
-double SvNV(Sv)
-register SV *Sv;
+double
+SvNV(sv)
+register SV *sv;
{
- if (SvNOK(Sv))
- return SvNVX(Sv);
- if (SvIOK(Sv))
- return (double)SvIVX(Sv);
- return sv_2nv(Sv);
+ if (SvNOK(sv))
+ return SvNVX(sv);
+ return sv_2nv(sv);
}
-#endif /* SvNV */
+#endif /* !SvNV */
#ifdef CRIPPLED_CC
char *
sv_untaint(sv)
SV *sv;
{
- MAGIC *mg = mg_find(sv, 't');
- if (mg)
- mg->mg_len &= ~1;
+ if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
+ MAGIC *mg = mg_find(sv, 't');
+ if (mg)
+ mg->mg_len &= ~1;
+ }
}
bool
sv_tainted(sv)
SV *sv;
{
- MAGIC *mg = mg_find(sv, 't');
- return (mg && ((mg->mg_len & 1)
- || (mg->mg_len & 2) && mg->mg_obj == 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;
+ }
+ return FALSE;
}
#ifdef DEBUGGING
if (type >= SVt_PVIV || type == SVt_IV)
PerlIO_printf(Perl_debug_log, " IV = %ld\n", (long)SvIVX(sv));
if (type >= SVt_PVNV || type == SVt_NV) {
- NUMERIC_STANDARD();
+ SET_NUMERIC_STANDARD();
PerlIO_printf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
}
if (SvROK(sv)) {
projects / p5sagit/p5-mst-13.2.git / blobdiff