/* sv.c
*
- * Copyright (c) 1991-1997, Larry Wall
+ * Copyright (c) 1991-1999, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
#endif
#endif
-#if defined(USE_STDIO_PTR) && defined(STDIO_PTR_LVALUE) && defined(STDIO_CNT_LVALUE) && !defined(__QNX__)
-# define FAST_SV_GETS
-#endif
-
#ifdef PERL_OBJECT
#define FCALL this->*f
#define VTBL this->*vtbl
#else /* !PERL_OBJECT */
-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));
-static XPV *more_xpv _((void));
-static XRV *more_xrv _((void));
-static XPVIV *new_xiv _((void));
-static XPVNV *new_xnv _((void));
-static XPV *new_xpv _((void));
-static XRV *new_xrv _((void));
-static void del_xiv _((XPVIV* p));
-static void del_xnv _((XPVNV* p));
-static void del_xpv _((XPV* p));
-static void del_xrv _((XRV* p));
-static void sv_mortalgrow _((void));
-static void sv_unglob _((SV* sv));
-static void sv_check_thinkfirst _((SV *sv));
+static IV asIV (SV* sv);
+static UV asUV (SV* sv);
+static SV *more_sv (void);
+static void more_xiv (void);
+static void more_xnv (void);
+static void more_xpv (void);
+static void more_xrv (void);
+static XPVIV *new_xiv (void);
+static XPVNV *new_xnv (void);
+static XPV *new_xpv (void);
+static XRV *new_xrv (void);
+static void del_xiv (XPVIV* p);
+static void del_xnv (XPVNV* p);
+static void del_xpv (XPV* p);
+static void del_xrv (XRV* p);
+static void sv_unglob (SV* sv);
+static void sv_add_backref (SV *tsv, SV *sv);
+static void sv_del_backref (SV *sv);
#ifndef PURIFY
static void *my_safemalloc(MEM_SIZE size);
#endif
-typedef void (*SVFUNC) _((SV*));
+typedef void (*SVFUNC) (SV*);
#define VTBL *vtbl
#define FCALL *f
#endif /* PERL_OBJECT */
-#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_check_thinkfirst(sv)
+#define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
#ifdef PURIFY
-#define new_SV(p) \
- do { \
- LOCK_SV_MUTEX; \
- (p) = (SV*)safemalloc(sizeof(SV)); \
- reg_add(p); \
- UNLOCK_SV_MUTEX; \
- } while (0)
-
-#define del_SV(p) \
- do { \
- LOCK_SV_MUTEX; \
- reg_remove(p); \
- Safefree((char*)(p)); \
- UNLOCK_SV_MUTEX; \
- } while (0)
+#define new_SV(p) \
+ STMT_START { \
+ LOCK_SV_MUTEX; \
+ (p) = (SV*)safemalloc(sizeof(SV)); \
+ reg_add(p); \
+ UNLOCK_SV_MUTEX; \
+ SvANY(p) = 0; \
+ SvREFCNT(p) = 1; \
+ SvFLAGS(p) = 0; \
+ } STMT_END
+
+#define del_SV(p) \
+ STMT_START { \
+ LOCK_SV_MUTEX; \
+ reg_remove(p); \
+ Safefree((char*)(p)); \
+ UNLOCK_SV_MUTEX; \
+ } STMT_END
static SV **registry;
static I32 registry_size;
#define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
#define REG_REPLACE(sv,a,b) \
- do { \
- void* p = sv->sv_any; \
- I32 h = REGHASH(sv, registry_size); \
- I32 i = h; \
- while (registry[i] != (a)) { \
- if (++i >= registry_size) \
- i = 0; \
- if (i == h) \
- die("SV registry bug"); \
- } \
- registry[i] = (b); \
- } while (0)
+ STMT_START { \
+ void* p = sv->sv_any; \
+ I32 h = REGHASH(sv, registry_size); \
+ I32 i = h; \
+ while (registry[i] != (a)) { \
+ if (++i >= registry_size) \
+ i = 0; \
+ if (i == h) \
+ die("SV registry bug"); \
+ } \
+ registry[i] = (b); \
+ } STMT_END
#define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
#define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
-static void
-reg_add(sv)
-SV* sv;
+STATIC void
+reg_add(SV *sv)
{
if (PL_sv_count >= (registry_size >> 1))
{
++PL_sv_count;
}
-static void
-reg_remove(sv)
-SV* sv;
+STATIC void
+reg_remove(SV *sv)
{
REG_REMOVE(sv);
--PL_sv_count;
}
-static void
-visit(f)
-SVFUNC f;
+STATIC void
+visit(SVFUNC f)
{
I32 i;
}
void
-sv_add_arena(ptr, size, flags)
-char* ptr;
-U32 size;
-U32 flags;
+sv_add_arena(char *ptr, U32 size, U32 flags)
{
if (!(flags & SVf_FAKE))
Safefree(ptr);
* "A time to plant, and a time to uproot what was planted..."
*/
-#define plant_SV(p) \
- do { \
- SvANY(p) = (void *)PL_sv_root; \
- SvFLAGS(p) = SVTYPEMASK; \
- PL_sv_root = (p); \
- --PL_sv_count; \
- } while (0)
+#define plant_SV(p) \
+ STMT_START { \
+ SvANY(p) = (void *)PL_sv_root; \
+ SvFLAGS(p) = SVTYPEMASK; \
+ PL_sv_root = (p); \
+ --PL_sv_count; \
+ } STMT_END
/* sv_mutex must be held while calling uproot_SV() */
-#define uproot_SV(p) \
- do { \
- (p) = PL_sv_root; \
- PL_sv_root = (SV*)SvANY(p); \
- ++PL_sv_count; \
- } while (0)
-
-#define new_SV(p) do { \
- LOCK_SV_MUTEX; \
- if (PL_sv_root) \
- uproot_SV(p); \
- else \
- (p) = more_sv(); \
- UNLOCK_SV_MUTEX; \
- } while (0)
+#define uproot_SV(p) \
+ STMT_START { \
+ (p) = PL_sv_root; \
+ PL_sv_root = (SV*)SvANY(p); \
+ ++PL_sv_count; \
+ } STMT_END
+
+#define new_SV(p) \
+ STMT_START { \
+ LOCK_SV_MUTEX; \
+ if (PL_sv_root) \
+ uproot_SV(p); \
+ else \
+ (p) = more_sv(); \
+ UNLOCK_SV_MUTEX; \
+ SvANY(p) = 0; \
+ SvREFCNT(p) = 1; \
+ SvFLAGS(p) = 0; \
+ } STMT_END
#ifdef DEBUGGING
-#define del_SV(p) do { \
- LOCK_SV_MUTEX; \
- if (PL_debug & 32768) \
- del_sv(p); \
- else \
- plant_SV(p); \
- UNLOCK_SV_MUTEX; \
- } while (0)
+#define del_SV(p) \
+ STMT_START { \
+ LOCK_SV_MUTEX; \
+ if (PL_debug & 32768) \
+ del_sv(p); \
+ else \
+ plant_SV(p); \
+ UNLOCK_SV_MUTEX; \
+ } STMT_END
STATIC void
del_sv(SV *p)
new_xiv(void)
{
IV* xiv;
- if (PL_xiv_root) {
- xiv = PL_xiv_root;
- /*
- * See comment in more_xiv() -- RAM.
- */
- PL_xiv_root = *(IV**)xiv;
- return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
- }
- return more_xiv();
+ LOCK_SV_MUTEX;
+ if (!PL_xiv_root)
+ more_xiv();
+ xiv = PL_xiv_root;
+ /*
+ * See comment in more_xiv() -- RAM.
+ */
+ PL_xiv_root = *(IV**)xiv;
+ UNLOCK_SV_MUTEX;
+ return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
}
STATIC void
del_xiv(XPVIV *p)
{
IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
+ LOCK_SV_MUTEX;
*(IV**)xiv = PL_xiv_root;
PL_xiv_root = xiv;
+ UNLOCK_SV_MUTEX;
}
-STATIC XPVIV*
+STATIC void
more_xiv(void)
{
register IV* xiv;
xiv++;
}
*(IV**)xiv = 0;
- return new_xiv();
}
STATIC XPVNV*
new_xnv(void)
{
double* xnv;
- if (PL_xnv_root) {
- xnv = PL_xnv_root;
- PL_xnv_root = *(double**)xnv;
- return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
- }
- return more_xnv();
+ LOCK_SV_MUTEX;
+ if (!PL_xnv_root)
+ more_xnv();
+ xnv = PL_xnv_root;
+ PL_xnv_root = *(double**)xnv;
+ UNLOCK_SV_MUTEX;
+ return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
}
STATIC void
del_xnv(XPVNV *p)
{
double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
+ LOCK_SV_MUTEX;
*(double**)xnv = PL_xnv_root;
PL_xnv_root = xnv;
+ UNLOCK_SV_MUTEX;
}
-STATIC XPVNV*
+STATIC void
more_xnv(void)
{
register double* xnv;
xnv++;
}
*(double**)xnv = 0;
- return new_xnv();
}
STATIC XRV*
new_xrv(void)
{
XRV* xrv;
- if (PL_xrv_root) {
- xrv = PL_xrv_root;
- PL_xrv_root = (XRV*)xrv->xrv_rv;
- return xrv;
- }
- return more_xrv();
+ LOCK_SV_MUTEX;
+ if (!PL_xrv_root)
+ more_xrv();
+ xrv = PL_xrv_root;
+ PL_xrv_root = (XRV*)xrv->xrv_rv;
+ UNLOCK_SV_MUTEX;
+ return xrv;
}
STATIC void
del_xrv(XRV *p)
{
+ LOCK_SV_MUTEX;
p->xrv_rv = (SV*)PL_xrv_root;
PL_xrv_root = p;
+ UNLOCK_SV_MUTEX;
}
-STATIC XRV*
+STATIC void
more_xrv(void)
{
register XRV* xrv;
xrv++;
}
xrv->xrv_rv = 0;
- return new_xrv();
}
STATIC XPV*
new_xpv(void)
{
XPV* xpv;
- if (PL_xpv_root) {
- xpv = PL_xpv_root;
- PL_xpv_root = (XPV*)xpv->xpv_pv;
- return xpv;
- }
- return more_xpv();
+ LOCK_SV_MUTEX;
+ if (!PL_xpv_root)
+ more_xpv();
+ xpv = PL_xpv_root;
+ PL_xpv_root = (XPV*)xpv->xpv_pv;
+ UNLOCK_SV_MUTEX;
+ return xpv;
}
STATIC void
del_xpv(XPV *p)
{
+ LOCK_SV_MUTEX;
p->xpv_pv = (char*)PL_xpv_root;
PL_xpv_root = p;
+ UNLOCK_SV_MUTEX;
}
-STATIC XPV*
+STATIC void
more_xpv(void)
{
register XPV* xpv;
xpv++;
}
xpv->xpv_pv = 0;
- return new_xpv();
}
#ifdef PURIFY
#ifdef PURIFY
# define my_safemalloc(s) safemalloc(s)
-# define my_safefree(s) free(s)
+# define my_safefree(s) safefree(s)
#else
STATIC void*
my_safemalloc(MEM_SIZE size)
cur = 0;
len = 0;
nv = SvNVX(sv);
- iv = I_32(nv);
+ iv = I_V(nv);
magic = 0;
stash = 0;
del_XNV(SvANY(sv));
return TRUE;
}
-char *
-sv_peek(SV *sv)
-{
-#ifdef DEBUGGING
- SV *t = sv_newmortal();
- STRLEN prevlen;
- int unref = 0;
-
- sv_setpvn(t, "", 0);
- retry:
- if (!sv) {
- sv_catpv(t, "VOID");
- goto finish;
- }
- else if (sv == (SV*)0x55555555 || SvTYPE(sv) == 'U') {
- sv_catpv(t, "WILD");
- goto finish;
- }
- else if (sv == &PL_sv_undef || sv == &PL_sv_no || sv == &PL_sv_yes) {
- if (sv == &PL_sv_undef) {
- sv_catpv(t, "SV_UNDEF");
- if (!(SvFLAGS(sv) & (SVf_OK|SVf_OOK|SVs_OBJECT|
- SVs_GMG|SVs_SMG|SVs_RMG)) &&
- SvREADONLY(sv))
- goto finish;
- }
- else if (sv == &PL_sv_no) {
- sv_catpv(t, "SV_NO");
- if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
- SVs_GMG|SVs_SMG|SVs_RMG)) &&
- !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
- SVp_POK|SVp_NOK)) &&
- SvCUR(sv) == 0 &&
- SvNVX(sv) == 0.0)
- goto finish;
- }
- else {
- sv_catpv(t, "SV_YES");
- if (!(SvFLAGS(sv) & (SVf_ROK|SVf_OOK|SVs_OBJECT|
- SVs_GMG|SVs_SMG|SVs_RMG)) &&
- !(~SvFLAGS(sv) & (SVf_POK|SVf_NOK|SVf_READONLY|
- SVp_POK|SVp_NOK)) &&
- SvCUR(sv) == 1 &&
- SvPVX(sv) && *SvPVX(sv) == '1' &&
- SvNVX(sv) == 1.0)
- goto finish;
- }
- sv_catpv(t, ":");
- }
- else if (SvREFCNT(sv) == 0) {
- sv_catpv(t, "(");
- unref++;
- }
- if (SvROK(sv)) {
- sv_catpv(t, "\\");
- if (SvCUR(t) + unref > 10) {
- SvCUR(t) = unref + 3;
- *SvEND(t) = '\0';
- sv_catpv(t, "...");
- goto finish;
- }
- sv = (SV*)SvRV(sv);
- goto retry;
- }
- switch (SvTYPE(sv)) {
- default:
- sv_catpv(t, "FREED");
- goto finish;
-
- case SVt_NULL:
- sv_catpv(t, "UNDEF");
- goto finish;
- case SVt_IV:
- sv_catpv(t, "IV");
- break;
- case SVt_NV:
- sv_catpv(t, "NV");
- break;
- case SVt_RV:
- sv_catpv(t, "RV");
- break;
- case SVt_PV:
- sv_catpv(t, "PV");
- break;
- case SVt_PVIV:
- sv_catpv(t, "PVIV");
- break;
- case SVt_PVNV:
- sv_catpv(t, "PVNV");
- break;
- case SVt_PVMG:
- sv_catpv(t, "PVMG");
- break;
- case SVt_PVLV:
- sv_catpv(t, "PVLV");
- break;
- case SVt_PVAV:
- sv_catpv(t, "AV");
- break;
- case SVt_PVHV:
- sv_catpv(t, "HV");
- break;
- case SVt_PVCV:
- if (CvGV(sv))
- sv_catpvf(t, "CV(%s)", GvNAME(CvGV(sv)));
- else
- sv_catpv(t, "CV()");
- goto finish;
- case SVt_PVGV:
- sv_catpv(t, "GV");
- break;
- case SVt_PVBM:
- sv_catpv(t, "BM");
- break;
- case SVt_PVFM:
- sv_catpv(t, "FM");
- break;
- case SVt_PVIO:
- sv_catpv(t, "IO");
- break;
- }
-
- if (SvPOKp(sv)) {
- if (!SvPVX(sv))
- sv_catpv(t, "(null)");
- if (SvOOK(sv))
- sv_catpvf(t, "(%ld+\"%.127s\")",(long)SvIVX(sv),SvPVX(sv));
- else
- sv_catpvf(t, "(\"%.127s\")",SvPVX(sv));
- }
- else if (SvNOKp(sv)) {
- SET_NUMERIC_STANDARD();
- sv_catpvf(t, "(%g)",SvNVX(sv));
- }
- else if (SvIOKp(sv))
- sv_catpvf(t, "(%ld)",(long)SvIVX(sv));
- else
- sv_catpv(t, "()");
-
- finish:
- if (unref) {
- while (unref--)
- sv_catpv(t, ")");
- }
- return SvPV(t, PL_na);
-#else /* DEBUGGING */
- return "";
-#endif /* DEBUGGING */
-}
-
int
sv_backoff(register SV *sv)
{
}
char *
-#ifndef DOSISH
-sv_grow(register SV *sv, register I32 newlen)
-#else
-sv_grow(SV* sv, unsigned long newlen)
-#endif
+sv_grow(register SV *sv, register STRLEN newlen)
{
register char *s;
break;
case SVt_PVGV:
- if (SvFAKE(sv)) {
- sv_unglob(sv);
- break;
- }
- /* FALL THROUGH */
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
{
dTHR;
croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
- op_desc[PL_op->op_type]);
+ PL_op_desc[PL_op->op_type]);
}
}
(void)SvIOK_only(sv); /* validate number */
void
sv_setuv(register SV *sv, UV u)
{
- if (u <= IV_MAX)
- sv_setiv(sv, u);
- else
- sv_setnv(sv, (double)u);
+ sv_setiv(sv, 0);
+ SvIsUV_on(sv);
+ SvUVX(sv) = u;
}
void
break;
case SVt_PVGV:
- if (SvFAKE(sv)) {
- sv_unglob(sv);
- break;
- }
- /* FALL THROUGH */
case SVt_PVAV:
case SVt_PVHV:
case SVt_PVCV:
{
dTHR;
croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
- op_name[PL_op->op_type]);
+ PL_op_name[PL_op->op_type]);
}
}
SvNVX(sv) = num;
if (PL_op)
warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
- op_name[PL_op->op_type]);
+ PL_op_name[PL_op->op_type]);
else
warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
}
+/* the number can be converted to _integer_ with atol() */
+#define IS_NUMBER_TO_INT_BY_ATOL 0x01
+#define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
+#define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
+#define IS_NUMBER_NEG 0x08 /* not good to cache UV */
+
+/* Actually, ISO C leaves conversion of UV to IV undefined, but
+ until proven guilty, assume that things are not that bad... */
+
IV
sv_2iv(register SV *sv)
{
if (SvIOKp(sv))
return SvIVX(sv);
if (SvNOKp(sv)) {
- if (SvNVX(sv) < 0.0)
- return I_V(SvNVX(sv));
- else
- return (IV) U_V(SvNVX(sv));
+ return I_V(SvNVX(sv));
}
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
}
return 0;
}
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
-#ifdef OVERLOAD
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
- return SvIV(tmpstr);
-#endif /* OVERLOAD */
+ return SvIV(tmpstr);
return (IV)SvRV(sv);
}
if (SvREADONLY(sv)) {
if (SvNOKp(sv)) {
- if (SvNVX(sv) < 0.0)
- return I_V(SvNVX(sv));
- else
- return (IV) U_V(SvNVX(sv));
+ return I_V(SvNVX(sv));
}
if (SvPOKp(sv) && SvLEN(sv))
return asIV(sv);
{
dTHR;
if (ckWARN(WARN_UNINITIALIZED))
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
}
return 0;
}
}
- switch (SvTYPE(sv)) {
- case SVt_NULL:
- sv_upgrade(sv, SVt_IV);
- break;
- case SVt_PV:
- sv_upgrade(sv, SVt_PVIV);
- break;
- case SVt_NV:
- sv_upgrade(sv, SVt_PVNV);
- break;
+ if (SvIOKp(sv)) {
+ if (SvIsUV(sv)) {
+ return (IV)(SvUVX(sv));
+ }
+ else {
+ return SvIVX(sv);
+ }
}
if (SvNOKp(sv)) {
+ /* We can cache the IV/UV value even if it not good enough
+ * to reconstruct NV, since the conversion to PV will prefer
+ * NV over IV/UV. XXXX 64-bit?
+ */
+
+ if (SvTYPE(sv) == SVt_NV)
+ sv_upgrade(sv, SVt_PVNV);
+
(void)SvIOK_on(sv);
- if (SvNVX(sv) < 0.0)
+ if (SvNVX(sv) < (double)IV_MAX + 0.5)
SvIVX(sv) = I_V(SvNVX(sv));
- else
+ else {
SvUVX(sv) = U_V(SvNVX(sv));
+ SvIsUV_on(sv);
+ ret_iv_max:
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
+ (unsigned long)sv,
+ (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
+ return (IV)SvUVX(sv);
+ }
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- (void)SvIOK_on(sv);
- SvIVX(sv) = asIV(sv);
+ I32 numtype = looks_like_number(sv);
+
+ /* We want to avoid a possible problem when we cache an IV which
+ may be later translated to an NV, and the resulting NV is not
+ the translation of the initial data.
+
+ This means that if we cache such an IV, we need to cache the
+ NV as well. Moreover, we trade speed for space, and do not
+ cache the NV if not needed.
+ */
+ if (numtype & IS_NUMBER_NOT_IV) {
+ /* May be not an integer. Need to cache NV if we cache IV
+ * - otherwise future conversion to NV will be wrong. */
+ double d;
+
+ SET_NUMERIC_STANDARD();
+ d = atof(SvPVX(sv));
+
+ if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ SvNVX(sv) = d;
+ (void)SvNOK_on(sv);
+ (void)SvIOK_on(sv);
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%lx 2nv(%g)\n",(unsigned long)sv,
+ SvNVX(sv)));
+ if (SvNVX(sv) < (double)IV_MAX + 0.5)
+ SvIVX(sv) = I_V(SvNVX(sv));
+ else {
+ SvUVX(sv) = U_V(SvNVX(sv));
+ SvIsUV_on(sv);
+ goto ret_iv_max;
+ }
+ }
+ else if (numtype) {
+ /* The NV may be reconstructed from IV - safe to cache IV,
+ which may be calculated by atol(). */
+ if (SvTYPE(sv) == SVt_PV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
+ }
+ else { /* Not a number. Cache 0. */
+ dTHR;
+
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ SvIVX(sv) = 0;
+ (void)SvIOK_on(sv);
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
}
else {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ if (SvTYPE(sv) < SVt_IV)
+ /* Typically the caller expects that sv_any is not NULL now. */
+ sv_upgrade(sv, SVt_IV);
return 0;
}
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
(unsigned long)sv,(long)SvIVX(sv)));
- return SvIVX(sv);
+ return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
}
UV
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
}
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 SvUV(tmpstr);
return (UV)SvRV(sv);
}
if (SvREADONLY(sv)) {
{
dTHR;
if (ckWARN(WARN_UNINITIALIZED))
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
}
return 0;
}
}
- switch (SvTYPE(sv)) {
- case SVt_NULL:
- sv_upgrade(sv, SVt_IV);
- break;
- case SVt_PV:
- sv_upgrade(sv, SVt_PVIV);
- break;
- case SVt_NV:
- sv_upgrade(sv, SVt_PVNV);
- break;
+ if (SvIOKp(sv)) {
+ if (SvIsUV(sv)) {
+ return SvUVX(sv);
+ }
+ else {
+ return (UV)SvIVX(sv);
+ }
}
if (SvNOKp(sv)) {
+ /* We can cache the IV/UV value even if it not good enough
+ * to reconstruct NV, since the conversion to PV will prefer
+ * NV over IV/UV. XXXX 64-bit?
+ */
+ if (SvTYPE(sv) == SVt_NV)
+ sv_upgrade(sv, SVt_PVNV);
(void)SvIOK_on(sv);
- SvUVX(sv) = U_V(SvNVX(sv));
+ if (SvNVX(sv) >= -0.5) {
+ SvIsUV_on(sv);
+ SvUVX(sv) = U_V(SvNVX(sv));
+ }
+ else {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ ret_zero:
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%lx 2uv(%ld => %lu) (as signed)\n",
+ (unsigned long)sv,(long)SvIVX(sv),
+ (long)(UV)SvIVX(sv)));
+ return (UV)SvIVX(sv);
+ }
}
else if (SvPOKp(sv) && SvLEN(sv)) {
- (void)SvIOK_on(sv);
- SvUVX(sv) = asUV(sv);
+ I32 numtype = looks_like_number(sv);
+
+ /* We want to avoid a possible problem when we cache a UV which
+ may be later translated to an NV, and the resulting NV is not
+ the translation of the initial data.
+
+ This means that if we cache such a UV, we need to cache the
+ NV as well. Moreover, we trade speed for space, and do not
+ cache the NV if not needed.
+ */
+ if (numtype & IS_NUMBER_NOT_IV) {
+ /* May be not an integer. Need to cache NV if we cache IV
+ * - otherwise future conversion to NV will be wrong. */
+ double d;
+
+ SET_NUMERIC_STANDARD();
+ d = atof(SvPVX(sv)); /* XXXX 64-bit? */
+
+ if (SvTYPE(sv) < SVt_PVNV)
+ sv_upgrade(sv, SVt_PVNV);
+ SvNVX(sv) = d;
+ (void)SvNOK_on(sv);
+ (void)SvIOK_on(sv);
+ DEBUG_c(PerlIO_printf(Perl_debug_log,
+ "0x%lx 2nv(%g)\n",(unsigned long)sv,
+ SvNVX(sv)));
+ if (SvNVX(sv) < -0.5) {
+ SvIVX(sv) = I_V(SvNVX(sv));
+ goto ret_zero;
+ } else {
+ SvUVX(sv) = U_V(SvNVX(sv));
+ SvIsUV_on(sv);
+ }
+ }
+ else if (numtype & IS_NUMBER_NEG) {
+ /* The NV may be reconstructed from IV - safe to cache IV,
+ which may be calculated by atol(). */
+ if (SvTYPE(sv) == SVt_PV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
+ }
+ else if (numtype) { /* Non-negative */
+ /* The NV may be reconstructed from UV - safe to cache UV,
+ which may be calculated by strtoul()/atol. */
+ if (SvTYPE(sv) == SVt_PV)
+ sv_upgrade(sv, SVt_PVIV);
+ (void)SvIOK_on(sv);
+ (void)SvIsUV_on(sv);
+#ifdef HAS_STRTOUL
+ SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
+#else /* no atou(), but we know the number fits into IV... */
+ /* The only problem may be if it is negative... */
+ SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
+#endif
+ }
+ else { /* Not a number. Cache 0. */
+ dTHR;
+
+ if (SvTYPE(sv) < SVt_PVIV)
+ sv_upgrade(sv, SVt_PVIV);
+ SvUVX(sv) = 0; /* We assume that 0s have the
+ same bitmap in IV and UV. */
+ (void)SvIOK_on(sv);
+ (void)SvIsUV_on(sv);
+ if (ckWARN(WARN_NUMERIC))
+ not_a_number(sv);
+ }
}
else {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
}
+ if (SvTYPE(sv) < SVt_IV)
+ /* Typically the caller expects that sv_any is not NULL now. */
+ sv_upgrade(sv, SVt_IV);
return 0;
}
+
DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
(unsigned long)sv,SvUVX(sv)));
- return SvUVX(sv);
+ return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
}
double
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
- if (SvIOKp(sv))
- return (double)SvIVX(sv);
+ if (SvIOKp(sv)) {
+ if (SvIsUV(sv))
+ return (double)SvUVX(sv);
+ else
+ return (double)SvIVX(sv);
+ }
if (!SvROK(sv)) {
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
}
return 0;
}
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
-#ifdef OVERLOAD
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
- return SvNV(tmpstr);
-#endif /* OVERLOAD */
+ return SvNV(tmpstr);
return (double)(unsigned long)SvRV(sv);
}
if (SvREADONLY(sv)) {
SET_NUMERIC_STANDARD();
return atof(SvPVX(sv));
}
- if (SvIOKp(sv))
- return (double)SvIVX(sv);
+ if (SvIOKp(sv)) {
+ if (SvIsUV(sv))
+ return (double)SvUVX(sv);
+ else
+ return (double)SvIVX(sv);
+ }
if (ckWARN(WARN_UNINITIALIZED))
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
return 0.0;
}
}
if (SvIOKp(sv) &&
(!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
{
- SvNVX(sv) = (double)SvIVX(sv);
+ SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv);
}
else if (SvPOKp(sv) && SvLEN(sv)) {
dTHR;
else {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
+ if (SvTYPE(sv) < SVt_NV)
+ /* Typically the caller expects that sv_any is not NULL now. */
+ sv_upgrade(sv, SVt_NV);
return 0.0;
}
SvNOK_on(sv);
I32 numtype = looks_like_number(sv);
double d;
- if (numtype == 1)
- return atol(SvPVX(sv));
+ if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
+ return atol(SvPVX(sv)); /* XXXX 64-bit? */
if (!numtype) {
dTHR;
if (ckWARN(WARN_NUMERIC))
}
SET_NUMERIC_STANDARD();
d = atof(SvPVX(sv));
- if (d < 0.0)
- return I_V(d);
- else
- return (IV) U_V(d);
+ return I_V(d);
}
STATIC UV
I32 numtype = looks_like_number(sv);
#ifdef HAS_STRTOUL
- if (numtype == 1)
+ if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
return strtoul(SvPVX(sv), Null(char**), 10);
#endif
if (!numtype) {
return U_V(atof(SvPVX(sv)));
}
+/*
+ * Returns a combination of (advisory only - can get false negatives)
+ * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
+ * IS_NUMBER_NEG
+ * 0 if does not look like number.
+ *
+ * In fact possible values are 0 and
+ * IS_NUMBER_TO_INT_BY_ATOL 123
+ * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
+ * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
+ * with a possible addition of IS_NUMBER_NEG.
+ */
+
I32
looks_like_number(SV *sv)
{
+ /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
+ * using atof() may lose precision. */
register char *s;
register char *send;
register char *sbegin;
- I32 numtype;
+ register char *nbegin;
+ I32 numtype = 0;
STRLEN len;
if (SvPOK(sv)) {
s = sbegin;
while (isSPACE(*s))
s++;
- if (*s == '+' || *s == '-')
+ if (*s == '-') {
+ s++;
+ numtype = IS_NUMBER_NEG;
+ }
+ else if (*s == '+')
s++;
+ nbegin = s;
+ /*
+ * we return 1 if the number can be converted to _integer_ with atol()
+ * and 2 if you need (int)atof().
+ */
+
/* next must be digit or '.' */
if (isDIGIT(*s)) {
do {
s++;
} while (isDIGIT(*s));
+
+ if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
+ numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
+ else
+ numtype |= IS_NUMBER_TO_INT_BY_ATOL;
+
if (*s == '.') {
s++;
+ numtype |= IS_NUMBER_NOT_IV;
while (isDIGIT(*s)) /* optional digits after "." */
s++;
}
}
else if (*s == '.') {
s++;
+ numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
/* no digits before '.' means we need digits after it */
if (isDIGIT(*s)) {
do {
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;
+ numtype &= ~IS_NUMBER_NEG;
+ numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
s++;
if (*s == '+' || *s == '-')
s++;
if (s >= send)
return numtype;
if (len == 10 && memEQ(sbegin, "0 but true", 10))
- return 1;
+ return IS_NUMBER_TO_INT_BY_ATOL;
return 0;
}
char *
+sv_2pv_nolen(register SV *sv)
+{
+ STRLEN n_a;
+ return sv_2pv(sv, &n_a);
+}
+
+/* We assume that buf is at least TYPE_CHARS(UV) long. */
+STATIC char *
+uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
+{
+ STRLEN len;
+ char *ptr = buf + TYPE_CHARS(UV);
+ char *ebuf = ptr;
+ int sign;
+ char *p;
+
+ if (is_uv)
+ sign = 0;
+ else if (iv >= 0) {
+ uv = iv;
+ sign = 0;
+ } else {
+ uv = -iv;
+ sign = 1;
+ }
+ do {
+ *--ptr = '0' + (uv % 10);
+ } while (uv /= 10);
+ if (sign)
+ *--ptr = '-';
+ *peob = ebuf;
+ return ptr;
+}
+
+char *
sv_2pv(register SV *sv, STRLEN *lp)
{
register char *s;
int olderrno;
SV *tsv;
- char tmpbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
+ char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
+ char *tmpbuf = tbuf;
if (!sv) {
*lp = 0;
*lp = SvCUR(sv);
return SvPVX(sv);
}
- if (SvIOKp(sv)) {
- (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
+ if (SvIOKp(sv)) { /* XXXX 64-bit? */
+ if (SvIsUV(sv))
+ (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
+ else
+ (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
tsv = Nullsv;
goto tokensave;
}
if (!(SvFLAGS(sv) & SVs_PADTMP)) {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
}
*lp = 0;
return "";
}
if (SvTHINKFIRST(sv)) {
if (SvROK(sv)) {
-#ifdef OVERLOAD
SV* tmpstr;
if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
- return SvPV(tmpstr,*lp);
-#endif /* OVERLOAD */
+ return SvPV(tmpstr,*lp);
sv = (SV*)SvRV(sv);
if (!sv)
s = "NULLREF";
sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
else
sv_setpv(tsv, s);
+ /* XXXX 64-bit? */
sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
goto tokensaveref;
}
return s;
}
if (SvREADONLY(sv)) {
- if (SvNOKp(sv)) {
+ if (SvNOKp(sv)) { /* See note in sv_2uv() */
+ /* XXXX 64-bit? IV may have better precision... */
SET_NUMERIC_STANDARD();
Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
tsv = Nullsv;
goto tokensave;
}
if (SvIOKp(sv)) {
- (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
+ char *ebuf;
+
+ if (SvIsUV(sv))
+ tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
+ else
+ tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
+ *ebuf = 0;
tsv = Nullsv;
goto tokensave;
}
{
dTHR;
if (ckWARN(WARN_UNINITIALIZED))
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
}
*lp = 0;
return "";
}
}
- (void)SvUPGRADE(sv, SVt_PV);
- if (SvNOKp(sv)) {
+ if (SvNOKp(sv)) { /* See note in sv_2uv() */
+ /* XXXX 64-bit? IV may have better precision... */
if (SvTYPE(sv) < SVt_PVNV)
sv_upgrade(sv, SVt_PVNV);
SvGROW(sv, 28);
#endif
}
else if (SvIOKp(sv)) {
- U32 oldIOK = SvIOK(sv);
+ U32 isIOK = SvIOK(sv);
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf, *ptr;
+
if (SvTYPE(sv) < SVt_PVIV)
sv_upgrade(sv, SVt_PVIV);
- olderrno = errno; /* some Xenix systems wipe out errno here */
- sv_setpviv(sv, SvIVX(sv));
- errno = olderrno;
+ if (SvIsUV(sv)) {
+ ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
+ sv_setpvn(sv, ptr, ebuf - ptr);
+ SvIsUV_on(sv);
+ }
+ else {
+ ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
+ sv_setpvn(sv, ptr, ebuf - ptr);
+ }
s = SvEND(sv);
- if (oldIOK)
+ if (isIOK)
SvIOK_on(sv);
else
SvIOKp_on(sv);
else {
dTHR;
if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
- warner(WARN_UNINITIALIZED, warn_uninit);
+ warner(WARN_UNINITIALIZED, PL_warn_uninit);
*lp = 0;
+ if (SvTYPE(sv) < SVt_PV)
+ /* Typically the caller expects that sv_any is not NULL now. */
+ sv_upgrade(sv, SVt_PV);
return "";
}
*lp = s - SvPVX(sv);
if (!SvOK(sv))
return 0;
if (SvROK(sv)) {
-#ifdef OVERLOAD
- {
dTHR;
SV* tmpsv;
if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
- return SvTRUE(tmpsv);
- }
-#endif /* OVERLOAD */
+ return SvTRUE(tmpsv);
return SvRV(sv) != 0;
}
if (SvPOKp(sv)) {
stype = SvTYPE(sstr);
dtype = SvTYPE(dstr);
- if (dtype == SVt_PVGV && (SvFLAGS(dstr) & SVf_FAKE)) {
- sv_unglob(dstr); /* so fake GLOB won't perpetuate */
- sv_setpvn(dstr, "", 0);
- (void)SvPOK_only(dstr);
- dtype = SvTYPE(dstr);
- }
-
-#ifdef OVERLOAD
SvAMAGIC_off(dstr);
-#endif /* OVERLOAD */
+
/* There's a lot of redundancy below but we're going for speed here */
switch (stype) {
}
(void)SvIOK_only(dstr);
SvIVX(dstr) = SvIVX(sstr);
+ if (SvIsUV(sstr))
+ SvIsUV_on(dstr);
SvTAINT(dstr);
return;
}
case SVt_PVIO:
if (PL_op)
croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
- op_name[PL_op->op_type]);
+ PL_op_name[PL_op->op_type]);
else
croak("Bizarre copy of %s", sv_reftype(sstr, 0));
break;
}
}
if (stype == SVt_PVLV)
- SvUPGRADE(dstr, SVt_PVNV);
+ (void)SvUPGRADE(dstr, SVt_PVNV);
else
- SvUPGRADE(dstr, stype);
+ (void)SvUPGRADE(dstr, stype);
}
sflags = SvFLAGS(sstr);
}
if (SvPVX(dstr)) {
(void)SvOOK_off(dstr); /* backoff */
- Safefree(SvPVX(dstr));
+ if (SvLEN(dstr))
+ Safefree(SvPVX(dstr));
SvLEN(dstr)=SvCUR(dstr)=0;
}
}
if (sflags & SVp_IOK) {
(void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
+ if (SvIsUV(sstr))
+ SvIsUV_on(dstr);
}
-#ifdef OVERLOAD
if (SvAMAGIC(sstr)) {
SvAMAGIC_on(dstr);
}
-#endif /* OVERLOAD */
}
else if (sflags & SVp_POK) {
SvFLAGS(dstr) &= ~SVf_OOK;
Safefree(SvPVX(dstr) - SvIVX(dstr));
}
- else
+ else if (SvLEN(dstr))
Safefree(SvPVX(dstr));
}
(void)SvPOK_only(dstr);
if (sflags & SVp_IOK) {
(void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
+ if (SvIsUV(sstr))
+ SvIsUV_on(dstr);
}
}
else if (sflags & SVp_NOK) {
if (SvIOK(sstr)) {
(void)SvIOK_on(dstr);
SvIVX(dstr) = SvIVX(sstr);
+ /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
+ if (SvIsUV(sstr))
+ SvIsUV_on(dstr);
}
}
else if (sflags & SVp_IOK) {
(void)SvIOK_only(dstr);
SvIVX(dstr) = SvIVX(sstr);
+ if (SvIsUV(sstr))
+ SvIsUV_on(dstr);
}
else {
if (dtype == SVt_PVGV) {
(void)SvOK_off(sv);
return;
}
- if (SvTYPE(sv) >= SVt_PV) {
- if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
- sv_unglob(sv);
- }
- else
- sv_upgrade(sv, SVt_PV);
+ (void)SvUPGRADE(sv, SVt_PV);
SvGROW(sv, len + 1);
dptr = SvPVX(sv);
return;
}
len = strlen(ptr);
- if (SvTYPE(sv) >= SVt_PV) {
- if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
- sv_unglob(sv);
- }
- else
- sv_upgrade(sv, SVt_PV);
+ (void)SvUPGRADE(sv, SVt_PV);
SvGROW(sv, len + 1);
Move(ptr,SvPVX(sv),len+1,char);
return;
}
(void)SvOOK_off(sv);
- if (SvPVX(sv))
+ if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
Renew(ptr, len+1, char);
SvPVX(sv) = ptr;
SvSETMAGIC(sv);
}
-STATIC void
-sv_check_thinkfirst(register SV *sv)
+void
+sv_force_normal(register SV *sv)
{
if (SvREADONLY(sv)) {
dTHR;
if (PL_curcop != &PL_compiling)
- croak(no_modify);
+ croak(PL_no_modify);
}
if (SvROK(sv))
sv_unref(sv);
+ else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
+ sv_unglob(sv);
}
void
sv_upgrade(sv,SVt_PVIV);
if (!SvOOK(sv)) {
+ if (!SvLEN(sv)) { /* make copy of shared string */
+ char *pvx = SvPVX(sv);
+ STRLEN len = SvCUR(sv);
+ SvGROW(sv, len + 1);
+ Move(pvx,SvPVX(sv),len,char);
+ *SvEND(sv) = '\0';
+ }
SvIVX(sv) = 0;
SvFLAGS(sv) |= SVf_OOK;
}
- SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK);
+ SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
delta = ptr - SvPVX(sv);
SvLEN(sv) -= delta;
SvCUR(sv) -= delta;
}
void
-sv_catpvn(register SV *sv, register char *ptr, register STRLEN len)
+sv_catpvn(register SV *sv, register const char *ptr, register STRLEN len)
{
STRLEN tlen;
char *junk;
}
void
-sv_catpvn_mg(register SV *sv, register char *ptr, register STRLEN len)
+sv_catpvn_mg(register SV *sv, register const char *ptr, register STRLEN len)
{
sv_catpvn(sv,ptr,len);
SvSETMAGIC(sv);
}
void
-sv_catpv(register SV *sv, register char *ptr)
+sv_catpv(register SV *sv, register const char *ptr)
{
register STRLEN len;
STRLEN tlen;
}
void
-sv_catpv_mg(register SV *sv, register char *ptr)
+sv_catpv_mg(register SV *sv, register const char *ptr)
{
sv_catpv(sv,ptr);
SvSETMAGIC(sv);
register SV *sv;
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 1;
- SvFLAGS(sv) = 0;
if (len) {
sv_upgrade(sv, SVt_PV);
SvGROW(sv, len + 1);
/* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
void
-sv_magic(register SV *sv, SV *obj, int how, char *name, I32 namlen)
+sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen)
{
MAGIC* mg;
if (SvREADONLY(sv)) {
dTHR;
if (PL_curcop != &PL_compiling && !strchr("gBf", how))
- croak(no_modify);
+ croak(PL_no_modify);
}
if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
switch (how) {
case 0:
- mg->mg_virtual = &vtbl_sv;
+ mg->mg_virtual = &PL_vtbl_sv;
break;
-#ifdef OVERLOAD
case 'A':
- mg->mg_virtual = &vtbl_amagic;
+ mg->mg_virtual = &PL_vtbl_amagic;
break;
case 'a':
- mg->mg_virtual = &vtbl_amagicelem;
+ mg->mg_virtual = &PL_vtbl_amagicelem;
break;
case 'c':
mg->mg_virtual = 0;
break;
-#endif /* OVERLOAD */
case 'B':
- mg->mg_virtual = &vtbl_bm;
+ mg->mg_virtual = &PL_vtbl_bm;
+ break;
+ case 'D':
+ mg->mg_virtual = &PL_vtbl_regdata;
+ break;
+ case 'd':
+ mg->mg_virtual = &PL_vtbl_regdatum;
break;
case 'E':
- mg->mg_virtual = &vtbl_env;
+ mg->mg_virtual = &PL_vtbl_env;
break;
case 'f':
- mg->mg_virtual = &vtbl_fm;
+ mg->mg_virtual = &PL_vtbl_fm;
break;
case 'e':
- mg->mg_virtual = &vtbl_envelem;
+ mg->mg_virtual = &PL_vtbl_envelem;
break;
case 'g':
- mg->mg_virtual = &vtbl_mglob;
+ mg->mg_virtual = &PL_vtbl_mglob;
break;
case 'I':
- mg->mg_virtual = &vtbl_isa;
+ mg->mg_virtual = &PL_vtbl_isa;
break;
case 'i':
- mg->mg_virtual = &vtbl_isaelem;
+ mg->mg_virtual = &PL_vtbl_isaelem;
break;
case 'k':
- mg->mg_virtual = &vtbl_nkeys;
+ mg->mg_virtual = &PL_vtbl_nkeys;
break;
case 'L':
SvRMAGICAL_on(sv);
mg->mg_virtual = 0;
break;
case 'l':
- mg->mg_virtual = &vtbl_dbline;
+ mg->mg_virtual = &PL_vtbl_dbline;
break;
#ifdef USE_THREADS
case 'm':
- mg->mg_virtual = &vtbl_mutex;
+ mg->mg_virtual = &PL_vtbl_mutex;
break;
#endif /* USE_THREADS */
#ifdef USE_LOCALE_COLLATE
case 'o':
- mg->mg_virtual = &vtbl_collxfrm;
+ mg->mg_virtual = &PL_vtbl_collxfrm;
break;
#endif /* USE_LOCALE_COLLATE */
case 'P':
- mg->mg_virtual = &vtbl_pack;
+ mg->mg_virtual = &PL_vtbl_pack;
break;
case 'p':
case 'q':
- mg->mg_virtual = &vtbl_packelem;
+ mg->mg_virtual = &PL_vtbl_packelem;
break;
case 'r':
- mg->mg_virtual = &vtbl_regexp;
+ mg->mg_virtual = &PL_vtbl_regexp;
break;
case 'S':
- mg->mg_virtual = &vtbl_sig;
+ mg->mg_virtual = &PL_vtbl_sig;
break;
case 's':
- mg->mg_virtual = &vtbl_sigelem;
+ mg->mg_virtual = &PL_vtbl_sigelem;
break;
case 't':
- mg->mg_virtual = &vtbl_taint;
+ mg->mg_virtual = &PL_vtbl_taint;
mg->mg_len = 1;
break;
case 'U':
- mg->mg_virtual = &vtbl_uvar;
+ mg->mg_virtual = &PL_vtbl_uvar;
break;
case 'v':
- mg->mg_virtual = &vtbl_vec;
+ mg->mg_virtual = &PL_vtbl_vec;
break;
case 'x':
- mg->mg_virtual = &vtbl_substr;
+ mg->mg_virtual = &PL_vtbl_substr;
break;
case 'y':
- mg->mg_virtual = &vtbl_defelem;
+ mg->mg_virtual = &PL_vtbl_defelem;
break;
case '*':
- mg->mg_virtual = &vtbl_glob;
+ mg->mg_virtual = &PL_vtbl_glob;
break;
case '#':
- mg->mg_virtual = &vtbl_arylen;
+ mg->mg_virtual = &PL_vtbl_arylen;
break;
case '.':
- mg->mg_virtual = &vtbl_pos;
+ mg->mg_virtual = &PL_vtbl_pos;
+ break;
+ case '<':
+ mg->mg_virtual = &PL_vtbl_backref;
break;
case '~': /* Reserved for use by extensions not perl internals. */
/* Useful for attaching extension internal data to perl vars. */
return 0;
}
+SV *
+sv_rvweaken(SV *sv)
+{
+ SV *tsv;
+ if (!SvOK(sv)) /* let undefs pass */
+ return sv;
+ if (!SvROK(sv))
+ croak("Can't weaken a nonreference");
+ else if (SvWEAKREF(sv)) {
+ dTHR;
+ if (ckWARN(WARN_MISC))
+ warner(WARN_MISC, "Reference is already weak");
+ return sv;
+ }
+ tsv = SvRV(sv);
+ sv_add_backref(tsv, sv);
+ SvWEAKREF_on(sv);
+ SvREFCNT_dec(tsv);
+ return sv;
+}
+
+STATIC void
+sv_add_backref(SV *tsv, SV *sv)
+{
+ AV *av;
+ MAGIC *mg;
+ if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
+ av = (AV*)mg->mg_obj;
+ else {
+ av = newAV();
+ sv_magic(tsv, (SV*)av, '<', NULL, 0);
+ SvREFCNT_dec(av); /* for sv_magic */
+ }
+ av_push(av,sv);
+}
+
+STATIC void
+sv_del_backref(SV *sv)
+{
+ AV *av;
+ SV **svp;
+ I32 i;
+ SV *tsv = SvRV(sv);
+ MAGIC *mg;
+ if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
+ croak("panic: del_backref");
+ av = (AV *)mg->mg_obj;
+ svp = AvARRAY(av);
+ i = AvFILLp(av);
+ while (i >= 0) {
+ if (svp[i] == sv) {
+ svp[i] = &PL_sv_undef; /* XXX */
+ }
+ i--;
+ }
+}
+
void
sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
{
G_DISCARD|G_EVAL|G_KEEPERR);
SvREFCNT(sv)--;
POPSTACK;
+ SPAGAIN;
LEAVE;
}
} while (SvOBJECT(sv) && SvSTASH(sv) != stash);
del_XRV(SvANY(&tmpref));
+
+ if (SvREFCNT(sv)) {
+ if (PL_in_clean_objs)
+ croak("DESTROY created new reference to dead object '%s'",
+ HvNAME(stash));
+ /* DESTROY gave object new lease on life */
+ return;
+ }
}
if (SvOBJECT(sv)) {
if (SvTYPE(sv) != SVt_PVIO)
--PL_sv_objcount; /* XXX Might want something more general */
}
- if (SvREFCNT(sv)) {
- if (PL_in_clean_objs)
- croak("DESTROY created new reference to dead object");
- /* DESTROY gave object new lease on life */
- return;
- }
}
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
mg_free(sv);
IoIFP(sv) != PerlIO_stdin() &&
IoIFP(sv) != PerlIO_stdout() &&
IoIFP(sv) != PerlIO_stderr())
+ {
io_close((IO*)sv);
+ }
+ if (IoDIRP(sv)) {
+ PerlDir_close(IoDIRP(sv));
+ IoDIRP(sv) = 0;
+ }
Safefree(IoTOP_NAME(sv));
Safefree(IoFMT_NAME(sv));
Safefree(IoBOTTOM_NAME(sv));
/* FALL THROUGH */
case SVt_PV:
case SVt_RV:
- if (SvROK(sv))
- SvREFCNT_dec(SvRV(sv));
+ if (SvROK(sv)) {
+ if (SvWEAKREF(sv))
+ sv_del_backref(sv);
+ else
+ SvREFCNT_dec(SvRV(sv));
+ }
else if (SvPVX(sv) && SvLEN(sv))
Safefree(SvPVX(sv));
break;
send = s + len;
while (s < send && uoffset--)
s += UTF8SKIP(s);
+ if (s >= send)
+ s = send;
*offsetp = s - start;
if (lenp) {
I32 ulen = *lenp;
start = s;
while (s < send && ulen--)
s += UTF8SKIP(s);
+ if (s >= send)
+ s = send;
*lenp = s - start;
}
return;
SV_CHECK_THINKFIRST(sv);
(void)SvUPGRADE(sv, SVt_PV);
+
SvSCREAM_off(sv);
if (RsSNARF(PL_rs)) {
if (!sv)
return;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv)) {
dTHR;
if (PL_curcop != &PL_compiling)
- croak(no_modify);
+ croak(PL_no_modify);
}
if (SvROK(sv)) {
IV i;
-#ifdef OVERLOAD
- if (SvAMAGIC(sv) && AMG_CALLun(sv,inc)) return;
-#endif /* OVERLOAD */
+ if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
+ return;
i = (IV)SvRV(sv);
sv_unref(sv);
sv_setiv(sv, i);
}
}
- if (SvGMAGICAL(sv))
- mg_get(sv);
flags = SvFLAGS(sv);
if (flags & SVp_NOK) {
(void)SvNOK_only(sv);
return;
}
if (flags & SVp_IOK) {
- if (SvIVX(sv) == IV_MAX)
- sv_setnv(sv, (double)IV_MAX + 1.0);
- else {
- (void)SvIOK_only(sv);
- ++SvIVX(sv);
+ if (SvIsUV(sv)) {
+ if (SvUVX(sv) == UV_MAX)
+ sv_setnv(sv, (double)UV_MAX + 1.0);
+ else
+ (void)SvIOK_only_UV(sv);
+ ++SvUVX(sv);
+ } else {
+ if (SvIVX(sv) == IV_MAX)
+ sv_setnv(sv, (double)IV_MAX + 1.0);
+ else {
+ (void)SvIOK_only(sv);
+ ++SvIVX(sv);
+ }
}
return;
}
if (!sv)
return;
+ if (SvGMAGICAL(sv))
+ mg_get(sv);
if (SvTHINKFIRST(sv)) {
if (SvREADONLY(sv)) {
dTHR;
if (PL_curcop != &PL_compiling)
- croak(no_modify);
+ croak(PL_no_modify);
}
if (SvROK(sv)) {
IV i;
-#ifdef OVERLOAD
- if (SvAMAGIC(sv) && AMG_CALLun(sv,dec)) return;
-#endif /* OVERLOAD */
+ if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
+ return;
i = (IV)SvRV(sv);
sv_unref(sv);
sv_setiv(sv, i);
}
}
- if (SvGMAGICAL(sv))
- mg_get(sv);
flags = SvFLAGS(sv);
if (flags & SVp_NOK) {
SvNVX(sv) -= 1.0;
return;
}
if (flags & SVp_IOK) {
- if (SvIVX(sv) == IV_MIN)
- sv_setnv(sv, (double)IV_MIN - 1.0);
- else {
- (void)SvIOK_only(sv);
- --SvIVX(sv);
+ if (SvIsUV(sv)) {
+ if (SvUVX(sv) == 0) {
+ (void)SvIOK_only(sv);
+ SvIVX(sv) = -1;
+ }
+ else {
+ (void)SvIOK_only_UV(sv);
+ --SvUVX(sv);
+ }
+ } else {
+ if (SvIVX(sv) == IV_MIN)
+ sv_setnv(sv, (double)IV_MIN - 1.0);
+ else {
+ (void)SvIOK_only(sv);
+ --SvIVX(sv);
+ }
}
return;
}
* hopefully we won't free it until it has been assigned to a
* permanent location. */
-STATIC void
-sv_mortalgrow(void)
-{
- dTHR;
- PL_tmps_max += (PL_tmps_max < 512) ? 128 : 512;
- Renew(PL_tmps_stack, PL_tmps_max, SV*);
-}
-
SV *
sv_mortalcopy(SV *oldstr)
{
register SV *sv;
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 1;
- SvFLAGS(sv) = 0;
sv_setsv(sv,oldstr);
- if (++PL_tmps_ix >= PL_tmps_max)
- sv_mortalgrow();
- PL_tmps_stack[PL_tmps_ix] = sv;
+ EXTEND_MORTAL(1);
+ PL_tmps_stack[++PL_tmps_ix] = sv;
SvTEMP_on(sv);
return sv;
}
register SV *sv;
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 1;
SvFLAGS(sv) = SVs_TEMP;
- if (++PL_tmps_ix >= PL_tmps_max)
- sv_mortalgrow();
- PL_tmps_stack[PL_tmps_ix] = sv;
+ EXTEND_MORTAL(1);
+ PL_tmps_stack[++PL_tmps_ix] = sv;
return sv;
}
return sv;
if (SvREADONLY(sv) && SvIMMORTAL(sv))
return sv;
- if (++PL_tmps_ix >= PL_tmps_max)
- sv_mortalgrow();
- PL_tmps_stack[PL_tmps_ix] = sv;
+ EXTEND_MORTAL(1);
+ PL_tmps_stack[++PL_tmps_ix] = sv;
SvTEMP_on(sv);
return sv;
}
SV *
-newSVpv(char *s, STRLEN len)
+newSVpv(const char *s, STRLEN len)
{
register SV *sv;
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 1;
- SvFLAGS(sv) = 0;
if (!len)
len = strlen(s);
sv_setpvn(sv,s,len);
}
SV *
-newSVpvn(char *s, STRLEN len)
+newSVpvn(const char *s, STRLEN len)
{
register SV *sv;
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 1;
- SvFLAGS(sv) = 0;
sv_setpvn(sv,s,len);
return sv;
}
va_list args;
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 1;
- SvFLAGS(sv) = 0;
va_start(args, pat);
sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
va_end(args);
register SV *sv;
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 1;
- SvFLAGS(sv) = 0;
sv_setnv(sv,n);
return sv;
}
register SV *sv;
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 1;
- SvFLAGS(sv) = 0;
sv_setiv(sv,i);
return sv;
}
register SV *sv;
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 1;
- SvFLAGS(sv) = 0;
sv_upgrade(sv, SVt_RV);
SvTEMP_off(tmpRef);
SvRV(sv) = tmpRef;
return Nullsv;
}
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 1;
- SvFLAGS(sv) = 0;
if (SvTEMP(old)) {
SvTEMP_off(old);
sv_setsv(sv,old);
}
for (i = 0; i <= (I32) HvMAX(stash); i++) {
for (entry = HvARRAY(stash)[i];
- entry;
- entry = HeNEXT(entry)) {
+ entry;
+ entry = HeNEXT(entry))
+ {
if (!todo[(U8)*HeKEY(entry)])
continue;
gv = (GV*)HeVAL(entry);
sv = GvSV(gv);
+ if (SvTHINKFIRST(sv)) {
+ if (!SvREADONLY(sv) && SvROK(sv))
+ sv_unref(sv);
+ continue;
+ }
(void)SvOK_off(sv);
if (SvTYPE(sv) >= SVt_PV) {
SvCUR_set(sv, 0);
{
IO* io;
GV* gv;
+ STRLEN n_a;
switch (SvTYPE(sv)) {
case SVt_PVIO:
break;
default:
if (!SvOK(sv))
- croak(no_usym, "filehandle");
+ croak(PL_no_usym, "filehandle");
if (SvROK(sv))
return sv_2io(SvRV(sv));
- gv = gv_fetchpv(SvPV(sv,PL_na), FALSE, SVt_PVIO);
+ gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
if (gv)
io = GvIO(gv);
else
io = 0;
if (!io)
- croak("Bad filehandle: %s", SvPV(sv,PL_na));
+ croak("Bad filehandle: %s", SvPV(sv,n_a));
break;
}
return io;
{
GV *gv;
CV *cv;
+ STRLEN n_a;
if (!sv)
return *gvp = Nullgv, Nullcv;
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvROK(sv)) {
- cv = (CV*)SvRV(sv);
- if (SvTYPE(cv) != SVt_PVCV)
+ dTHR;
+ SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
+ tryAMAGICunDEREF(to_cv);
+
+ sv = SvRV(sv);
+ if (SvTYPE(sv) == SVt_PVCV) {
+ cv = (CV*)sv;
+ *gvp = Nullgv;
+ *st = CvSTASH(cv);
+ return cv;
+ }
+ else if(isGV(sv))
+ gv = (GV*)sv;
+ else
croak("Not a subroutine reference");
- *gvp = Nullgv;
- *st = CvSTASH(cv);
- return cv;
}
- if (isGV(sv))
+ else if (isGV(sv))
gv = (GV*)sv;
else
- gv = gv_fetchpv(SvPV(sv, PL_na), lref, SVt_PVCV);
+ gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
*gvp = gv;
if (!gv)
return Nullcv;
ENTER;
tmpsv = NEWSV(704,0);
gv_efullname3(tmpsv, gv, Nullch);
+ /* XXX this is probably not what they think they're getting.
+ * It has the same effect as "sub name;", i.e. just a forward
+ * declaration! */
newSUB(start_subparse(FALSE, 0),
newSVOP(OP_CONST, 0, tmpsv),
Nullop,
Nullop);
LEAVE;
if (!GvCVu(gv))
- croak("Unable to create sub named \"%s\"", SvPV(sv,PL_na));
+ croak("Unable to create sub named \"%s\"", SvPV(sv,n_a));
}
return GvCVu(gv);
}
IV
sv_iv(register SV *sv)
{
- if (SvIOK(sv))
+ if (SvIOK(sv)) {
+ if (SvIsUV(sv))
+ return (IV)SvUVX(sv);
return SvIVX(sv);
+ }
return sv_2iv(sv);
}
UV
sv_uv(register SV *sv)
{
- if (SvIOK(sv))
- return SvUVX(sv);
+ if (SvIOK(sv)) {
+ if (SvIsUV(sv))
+ return SvUVX(sv);
+ return (UV)SvIVX(sv);
+ }
return sv_2uv(sv);
}
}
char *
+sv_pv(SV *sv)
+{
+ STRLEN n_a;
+
+ if (SvPOK(sv))
+ return SvPVX(sv);
+
+ return sv_2pv(sv, &n_a);
+}
+
+char *
sv_pvn(SV *sv, STRLEN *lp)
{
if (SvPOK(sv)) {
{
char *s;
- if (SvREADONLY(sv)) {
- dTHR;
- if (PL_curcop != &PL_compiling)
- croak(no_modify);
- }
+ if (SvTHINKFIRST(sv) && !SvROK(sv))
+ sv_force_normal(sv);
if (SvPOK(sv)) {
*lp = SvCUR(sv);
}
else {
if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
- if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV) {
- sv_unglob(sv);
- s = SvPVX(sv);
- *lp = SvCUR(sv);
- }
- else {
- dTHR;
- croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
- op_name[PL_op->op_type]);
- }
+ dTHR;
+ croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
+ PL_op_name[PL_op->op_type]);
}
else
s = sv_2pv(sv, lp);
}
int
-sv_isa(SV *sv, char *name)
+sv_isa(SV *sv, const char *name)
{
if (!sv)
return 0;
}
SV*
-newSVrv(SV *rv, char *classname)
+newSVrv(SV *rv, const char *classname)
{
dTHR;
SV *sv;
new_SV(sv);
- SvANY(sv) = 0;
- SvREFCNT(sv) = 0;
- SvFLAGS(sv) = 0;
SV_CHECK_THINKFIRST(rv);
-#ifdef OVERLOAD
SvAMAGIC_off(rv);
-#endif /* OVERLOAD */
if (SvTYPE(rv) < SVt_RV)
sv_upgrade(rv, SVt_RV);
(void)SvOK_off(rv);
- SvRV(rv) = SvREFCNT_inc(sv);
+ SvRV(rv) = sv;
SvROK_on(rv);
if (classname) {
}
SV*
-sv_setref_pv(SV *rv, char *classname, void *pv)
+sv_setref_pv(SV *rv, const char *classname, void *pv)
{
if (!pv) {
sv_setsv(rv, &PL_sv_undef);
}
SV*
-sv_setref_iv(SV *rv, char *classname, IV iv)
+sv_setref_iv(SV *rv, const char *classname, IV iv)
{
sv_setiv(newSVrv(rv,classname), iv);
return rv;
}
SV*
-sv_setref_nv(SV *rv, char *classname, double nv)
+sv_setref_nv(SV *rv, const char *classname, double nv)
{
sv_setnv(newSVrv(rv,classname), nv);
return rv;
}
SV*
-sv_setref_pvn(SV *rv, char *classname, char *pv, I32 n)
+sv_setref_pvn(SV *rv, const char *classname, char *pv, STRLEN n)
{
sv_setpvn(newSVrv(rv,classname), pv, n);
return rv;
tmpRef = SvRV(sv);
if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
if (SvREADONLY(tmpRef))
- croak(no_modify);
+ croak(PL_no_modify);
if (SvOBJECT(tmpRef)) {
if (SvTYPE(tmpRef) != SVt_PVIO)
--PL_sv_objcount;
(void)SvUPGRADE(tmpRef, SVt_PVMG);
SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
-#ifdef OVERLOAD
if (Gv_AMG(stash))
SvAMAGIC_on(sv);
else
SvAMAGIC_off(sv);
-#endif /* OVERLOAD */
return sv;
}
sv_unref(SV *sv)
{
SV* rv = SvRV(sv);
-
+
+ if (SvWEAKREF(sv)) {
+ sv_del_backref(sv);
+ SvWEAKREF_off(sv);
+ SvRV(sv) = 0;
+ return;
+ }
SvRV(sv) = 0;
SvROK_off(sv);
if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
void
sv_setpviv(SV *sv, IV iv)
{
- STRLEN len;
- char buf[TYPE_DIGITS(UV)];
- char *ptr = buf + sizeof(buf);
- int sign;
- UV uv;
- char *p;
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
- sv_setpvn(sv, "", 0);
- if (iv >= 0) {
- uv = iv;
- sign = 0;
- } else {
- uv = -iv;
- sign = 1;
- }
- do {
- *--ptr = '0' + (uv % 10);
- } while (uv /= 10);
- len = (buf + sizeof(buf)) - ptr;
- /* taking advantage of SvCUR(sv) == 0 */
- SvGROW(sv, sign + len + 1);
- p = SvPVX(sv);
- if (sign)
- *p++ = '-';
- memcpy(p, ptr, len);
- p += len;
- *p = '\0';
- SvCUR(sv) = p - SvPVX(sv);
+ sv_setpvn(sv, ptr, ebuf - ptr);
}
void
sv_setpviv_mg(SV *sv, IV iv)
{
- sv_setpviv(sv,iv);
+ char buf[TYPE_CHARS(UV)];
+ char *ebuf;
+ char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
+
+ sv_setpvn(sv, ptr, ebuf - ptr);
SvSETMAGIC(sv);
}
char *eptr = Nullch;
STRLEN elen = 0;
char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
-
- static char *efloatbuf = Nullch;
- static STRLEN efloatsize = 0;
-
char c;
int i;
unsigned base;
base = 10;
goto uns_integer;
+ case 'b':
+ base = 2;
+ goto uns_integer;
+
case 'O':
intsize = 'l';
/* FALL THROUGH */
if (alt && *eptr != '0')
*--eptr = '0';
break;
+ case 2:
+ do {
+ dig = uv & 1;
+ *--eptr = '0' + dig;
+ } while (uv >>= 1);
+ if (alt && *eptr != '0')
+ *--eptr = '0';
+ break;
default: /* it had better be ten or less */
do {
dig = uv % base;
need = width;
need += 20; /* fudge factor */
- if (efloatsize < need) {
- Safefree(efloatbuf);
- efloatsize = need + 20; /* more fudge */
- New(906, efloatbuf, efloatsize, char);
+ if (PL_efloatsize < need) {
+ Safefree(PL_efloatbuf);
+ PL_efloatsize = need + 20; /* more fudge */
+ New(906, PL_efloatbuf, PL_efloatsize, char);
}
eptr = ebuf + sizeof ebuf;
*--eptr = '#';
*--eptr = '%';
- (void)sprintf(efloatbuf, eptr, nv);
+ (void)sprintf(PL_efloatbuf, eptr, nv);
- eptr = efloatbuf;
- elen = strlen(efloatbuf);
+ eptr = PL_efloatbuf;
+ elen = strlen(PL_efloatbuf);
#ifdef LC_NUMERIC
/*
SvCUR(sv) = p - SvPVX(sv);
}
}
-
-void
-sv_dump(SV *sv)
-{
-#ifdef DEBUGGING
- SV *d = sv_newmortal();
- char *s;
- U32 flags;
- U32 type;
-
- if (!sv) {
- PerlIO_printf(Perl_debug_log, "SV = 0\n");
- return;
- }
-
- flags = SvFLAGS(sv);
- type = SvTYPE(sv);
-
- sv_setpvf(d, "(0x%lx)\n REFCNT = %ld\n FLAGS = (",
- (unsigned long)SvANY(sv), (long)SvREFCNT(sv));
- if (flags & SVs_PADBUSY) sv_catpv(d, "PADBUSY,");
- if (flags & SVs_PADTMP) sv_catpv(d, "PADTMP,");
- if (flags & SVs_PADMY) sv_catpv(d, "PADMY,");
- if (flags & SVs_TEMP) sv_catpv(d, "TEMP,");
- if (flags & SVs_OBJECT) sv_catpv(d, "OBJECT,");
- if (flags & SVs_GMG) sv_catpv(d, "GMG,");
- if (flags & SVs_SMG) sv_catpv(d, "SMG,");
- if (flags & SVs_RMG) sv_catpv(d, "RMG,");
-
- if (flags & SVf_IOK) sv_catpv(d, "IOK,");
- if (flags & SVf_NOK) sv_catpv(d, "NOK,");
- if (flags & SVf_POK) sv_catpv(d, "POK,");
- if (flags & SVf_ROK) sv_catpv(d, "ROK,");
- if (flags & SVf_OOK) sv_catpv(d, "OOK,");
- if (flags & SVf_FAKE) sv_catpv(d, "FAKE,");
- if (flags & SVf_READONLY) sv_catpv(d, "READONLY,");
-
-#ifdef OVERLOAD
- if (flags & SVf_AMAGIC) sv_catpv(d, "OVERLOAD,");
-#endif /* OVERLOAD */
- if (flags & SVp_IOK) sv_catpv(d, "pIOK,");
- if (flags & SVp_NOK) sv_catpv(d, "pNOK,");
- if (flags & SVp_POK) sv_catpv(d, "pPOK,");
- if (flags & SVp_SCREAM) sv_catpv(d, "SCREAM,");
-
- switch (type) {
- case SVt_PVCV:
- case SVt_PVFM:
- if (CvANON(sv)) sv_catpv(d, "ANON,");
- if (CvUNIQUE(sv)) sv_catpv(d, "UNIQUE,");
- if (CvCLONE(sv)) sv_catpv(d, "CLONE,");
- if (CvCLONED(sv)) sv_catpv(d, "CLONED,");
- if (CvNODEBUG(sv)) sv_catpv(d, "NODEBUG,");
- break;
- case SVt_PVHV:
- if (HvSHAREKEYS(sv)) sv_catpv(d, "SHAREKEYS,");
- if (HvLAZYDEL(sv)) sv_catpv(d, "LAZYDEL,");
- break;
- case SVt_PVGV:
- if (GvINTRO(sv)) sv_catpv(d, "INTRO,");
- if (GvMULTI(sv)) sv_catpv(d, "MULTI,");
- if (GvASSUMECV(sv)) sv_catpv(d, "ASSUMECV,");
- if (GvIMPORTED(sv)) {
- sv_catpv(d, "IMPORT");
- if (GvIMPORTED(sv) == GVf_IMPORTED)
- sv_catpv(d, "ALL,");
- else {
- sv_catpv(d, "(");
- if (GvIMPORTED_SV(sv)) sv_catpv(d, " SV");
- if (GvIMPORTED_AV(sv)) sv_catpv(d, " AV");
- if (GvIMPORTED_HV(sv)) sv_catpv(d, " HV");
- if (GvIMPORTED_CV(sv)) sv_catpv(d, " CV");
- sv_catpv(d, " ),");
- }
- }
- case SVt_PVBM:
- if (SvTAIL(sv)) sv_catpv(d, "TAIL,");
- if (SvCOMPILED(sv)) sv_catpv(d, "COMPILED,");
- break;
- }
-
- if (*(SvEND(d) - 1) == ',')
- SvPVX(d)[--SvCUR(d)] = '\0';
- sv_catpv(d, ")");
- s = SvPVX(d);
-
- PerlIO_printf(Perl_debug_log, "SV = ");
- switch (type) {
- case SVt_NULL:
- PerlIO_printf(Perl_debug_log, "NULL%s\n", s);
- return;
- case SVt_IV:
- PerlIO_printf(Perl_debug_log, "IV%s\n", s);
- break;
- case SVt_NV:
- PerlIO_printf(Perl_debug_log, "NV%s\n", s);
- break;
- case SVt_RV:
- PerlIO_printf(Perl_debug_log, "RV%s\n", s);
- break;
- case SVt_PV:
- PerlIO_printf(Perl_debug_log, "PV%s\n", s);
- break;
- case SVt_PVIV:
- PerlIO_printf(Perl_debug_log, "PVIV%s\n", s);
- break;
- case SVt_PVNV:
- PerlIO_printf(Perl_debug_log, "PVNV%s\n", s);
- break;
- case SVt_PVBM:
- PerlIO_printf(Perl_debug_log, "PVBM%s\n", s);
- break;
- case SVt_PVMG:
- PerlIO_printf(Perl_debug_log, "PVMG%s\n", s);
- break;
- case SVt_PVLV:
- PerlIO_printf(Perl_debug_log, "PVLV%s\n", s);
- break;
- case SVt_PVAV:
- PerlIO_printf(Perl_debug_log, "PVAV%s\n", s);
- break;
- case SVt_PVHV:
- PerlIO_printf(Perl_debug_log, "PVHV%s\n", s);
- break;
- case SVt_PVCV:
- PerlIO_printf(Perl_debug_log, "PVCV%s\n", s);
- break;
- case SVt_PVGV:
- PerlIO_printf(Perl_debug_log, "PVGV%s\n", s);
- break;
- case SVt_PVFM:
- PerlIO_printf(Perl_debug_log, "PVFM%s\n", s);
- break;
- case SVt_PVIO:
- PerlIO_printf(Perl_debug_log, "PVIO%s\n", s);
- break;
- default:
- PerlIO_printf(Perl_debug_log, "UNKNOWN%s\n", s);
- return;
- }
- 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) {
- SET_NUMERIC_STANDARD();
- PerlIO_printf(Perl_debug_log, " NV = %.*g\n", DBL_DIG, SvNVX(sv));
- }
- if (SvROK(sv)) {
- PerlIO_printf(Perl_debug_log, " RV = 0x%lx\n", (long)SvRV(sv));
- sv_dump(SvRV(sv));
- return;
- }
- if (type < SVt_PV)
- return;
- if (type <= SVt_PVLV) {
- if (SvPVX(sv))
- PerlIO_printf(Perl_debug_log, " PV = 0x%lx \"%s\"\n CUR = %ld\n LEN = %ld\n",
- (long)SvPVX(sv), SvPVX(sv), (long)SvCUR(sv), (long)SvLEN(sv));
- else
- PerlIO_printf(Perl_debug_log, " PV = 0\n");
- }
- if (type >= SVt_PVMG) {
- if (SvMAGIC(sv)) {
- PerlIO_printf(Perl_debug_log, " MAGIC = 0x%lx\n", (long)SvMAGIC(sv));
- }
- if (SvSTASH(sv))
- PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n", HvNAME(SvSTASH(sv)));
- }
- switch (type) {
- case SVt_PVLV:
- PerlIO_printf(Perl_debug_log, " TYPE = %c\n", LvTYPE(sv));
- PerlIO_printf(Perl_debug_log, " TARGOFF = %ld\n", (long)LvTARGOFF(sv));
- PerlIO_printf(Perl_debug_log, " TARGLEN = %ld\n", (long)LvTARGLEN(sv));
- PerlIO_printf(Perl_debug_log, " TARG = 0x%lx\n", (long)LvTARG(sv));
- sv_dump(LvTARG(sv));
- break;
- case SVt_PVAV:
- PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n", (long)AvARRAY(sv));
- PerlIO_printf(Perl_debug_log, " ALLOC = 0x%lx\n", (long)AvALLOC(sv));
- PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)AvFILLp(sv));
- PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)AvMAX(sv));
- PerlIO_printf(Perl_debug_log, " ARYLEN = 0x%lx\n", (long)AvARYLEN(sv));
- flags = AvFLAGS(sv);
- sv_setpv(d, "");
- if (flags & AVf_REAL) sv_catpv(d, ",REAL");
- if (flags & AVf_REIFY) sv_catpv(d, ",REIFY");
- if (flags & AVf_REUSED) sv_catpv(d, ",REUSED");
- PerlIO_printf(Perl_debug_log, " FLAGS = (%s)\n",
- SvCUR(d) ? SvPVX(d) + 1 : "");
- break;
- case SVt_PVHV:
- PerlIO_printf(Perl_debug_log, " ARRAY = 0x%lx\n",(long)HvARRAY(sv));
- PerlIO_printf(Perl_debug_log, " KEYS = %ld\n", (long)HvKEYS(sv));
- PerlIO_printf(Perl_debug_log, " FILL = %ld\n", (long)HvFILL(sv));
- PerlIO_printf(Perl_debug_log, " MAX = %ld\n", (long)HvMAX(sv));
- PerlIO_printf(Perl_debug_log, " RITER = %ld\n", (long)HvRITER(sv));
- PerlIO_printf(Perl_debug_log, " EITER = 0x%lx\n",(long) HvEITER(sv));
- if (HvPMROOT(sv))
- PerlIO_printf(Perl_debug_log, " PMROOT = 0x%lx\n",(long)HvPMROOT(sv));
- if (HvNAME(sv))
- PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", HvNAME(sv));
- break;
- case SVt_PVCV:
- if (SvPOK(sv))
- PerlIO_printf(Perl_debug_log, " PROTOTYPE = \"%s\"\n", SvPV(sv,PL_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));
- PerlIO_printf(Perl_debug_log, " XSUB = 0x%lx\n", (long)CvXSUB(sv));
- PerlIO_printf(Perl_debug_log, " XSUBANY = %ld\n", (long)CvXSUBANY(sv).any_i32);
- PerlIO_printf(Perl_debug_log, " GV = 0x%lx", (long)CvGV(sv));
- if (CvGV(sv) && GvNAME(CvGV(sv))) {
- PerlIO_printf(Perl_debug_log, " \"%s\"\n", GvNAME(CvGV(sv)));
- } else {
- PerlIO_printf(Perl_debug_log, "\n");
- }
- PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)CvFILEGV(sv));
- PerlIO_printf(Perl_debug_log, " DEPTH = %ld\n", (long)CvDEPTH(sv));
- PerlIO_printf(Perl_debug_log, " PADLIST = 0x%lx\n", (long)CvPADLIST(sv));
- PerlIO_printf(Perl_debug_log, " OUTSIDE = 0x%lx\n", (long)CvOUTSIDE(sv));
-#ifdef USE_THREADS
- PerlIO_printf(Perl_debug_log, " MUTEXP = 0x%lx\n", (long)CvMUTEXP(sv));
- PerlIO_printf(Perl_debug_log, " OWNER = 0x%lx\n", (long)CvOWNER(sv));
-#endif /* USE_THREADS */
- PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n",
- (unsigned long)CvFLAGS(sv));
- if (type == SVt_PVFM)
- PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)FmLINES(sv));
- break;
- case SVt_PVGV:
- PerlIO_printf(Perl_debug_log, " NAME = \"%s\"\n", GvNAME(sv));
- PerlIO_printf(Perl_debug_log, " NAMELEN = %ld\n", (long)GvNAMELEN(sv));
- PerlIO_printf(Perl_debug_log, " STASH = \"%s\"\n",
- SvTYPE(GvSTASH(sv)) == SVt_PVHV ? HvNAME(GvSTASH(sv)) : "(deleted)");
- PerlIO_printf(Perl_debug_log, " GP = 0x%lx\n", (long)GvGP(sv));
- PerlIO_printf(Perl_debug_log, " SV = 0x%lx\n", (long)GvSV(sv));
- PerlIO_printf(Perl_debug_log, " REFCNT = %ld\n", (long)GvREFCNT(sv));
- PerlIO_printf(Perl_debug_log, " IO = 0x%lx\n", (long)GvIOp(sv));
- PerlIO_printf(Perl_debug_log, " FORM = 0x%lx\n", (long)GvFORM(sv));
- PerlIO_printf(Perl_debug_log, " AV = 0x%lx\n", (long)GvAV(sv));
- PerlIO_printf(Perl_debug_log, " HV = 0x%lx\n", (long)GvHV(sv));
- PerlIO_printf(Perl_debug_log, " CV = 0x%lx\n", (long)GvCV(sv));
- PerlIO_printf(Perl_debug_log, " CVGEN = 0x%lx\n", (long)GvCVGEN(sv));
- PerlIO_printf(Perl_debug_log, " LASTEXPR = %ld\n", (long)GvLASTEXPR(sv));
- PerlIO_printf(Perl_debug_log, " LINE = %ld\n", (long)GvLINE(sv));
- PerlIO_printf(Perl_debug_log, " FILEGV = 0x%lx\n", (long)GvFILEGV(sv));
- PerlIO_printf(Perl_debug_log, " EGV = 0x%lx\n", (long)GvEGV(sv));
- break;
- case SVt_PVIO:
- PerlIO_printf(Perl_debug_log, " IFP = 0x%lx\n", (long)IoIFP(sv));
- PerlIO_printf(Perl_debug_log, " OFP = 0x%lx\n", (long)IoOFP(sv));
- PerlIO_printf(Perl_debug_log, " DIRP = 0x%lx\n", (long)IoDIRP(sv));
- PerlIO_printf(Perl_debug_log, " LINES = %ld\n", (long)IoLINES(sv));
- PerlIO_printf(Perl_debug_log, " PAGE = %ld\n", (long)IoPAGE(sv));
- PerlIO_printf(Perl_debug_log, " PAGE_LEN = %ld\n", (long)IoPAGE_LEN(sv));
- PerlIO_printf(Perl_debug_log, " LINES_LEFT = %ld\n", (long)IoLINES_LEFT(sv));
- PerlIO_printf(Perl_debug_log, " TOP_NAME = \"%s\"\n", IoTOP_NAME(sv));
- PerlIO_printf(Perl_debug_log, " TOP_GV = 0x%lx\n", (long)IoTOP_GV(sv));
- PerlIO_printf(Perl_debug_log, " FMT_NAME = \"%s\"\n", IoFMT_NAME(sv));
- PerlIO_printf(Perl_debug_log, " FMT_GV = 0x%lx\n", (long)IoFMT_GV(sv));
- PerlIO_printf(Perl_debug_log, " BOTTOM_NAME = \"%s\"\n", IoBOTTOM_NAME(sv));
- PerlIO_printf(Perl_debug_log, " BOTTOM_GV = 0x%lx\n", (long)IoBOTTOM_GV(sv));
- PerlIO_printf(Perl_debug_log, " SUBPROCESS = %ld\n", (long)IoSUBPROCESS(sv));
- PerlIO_printf(Perl_debug_log, " TYPE = %c\n", IoTYPE(sv));
- PerlIO_printf(Perl_debug_log, " FLAGS = 0x%lx\n", (long)IoFLAGS(sv));
- break;
- }
-#endif /* DEBUGGING */
-}
projects / p5sagit/p5-mst-13.2.git / blobdiff