3 * Copyright (c) 1991-1999, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
18 /* Use an overridden DBL_DIG */
22 # define DBL_DIG OVR_DBL_DIG
24 /* The following is all to get DBL_DIG, in order to pick a nice
25 default value for printing floating point numbers in Gconvert.
35 #define DBL_DIG 15 /* A guess that works lots of places */
40 #define FCALL this->*f
41 #define VTBL this->*vtbl
43 #else /* !PERL_OBJECT */
45 static IV asIV (SV* sv);
46 static UV asUV (SV* sv);
47 static SV *more_sv (void);
48 static void more_xiv (void);
49 static void more_xnv (void);
50 static void more_xpv (void);
51 static void more_xrv (void);
52 static XPVIV *new_xiv (void);
53 static XPVNV *new_xnv (void);
54 static XPV *new_xpv (void);
55 static XRV *new_xrv (void);
56 static void del_xiv (XPVIV* p);
57 static void del_xnv (XPVNV* p);
58 static void del_xpv (XPV* p);
59 static void del_xrv (XRV* p);
60 static void sv_unglob (SV* sv);
61 static void sv_add_backref (SV *tsv, SV *sv);
62 static void sv_del_backref (SV *sv);
65 static void *my_safemalloc(MEM_SIZE size);
68 typedef void (*SVFUNC) (SV*);
72 #endif /* PERL_OBJECT */
74 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
81 (p) = (SV*)safemalloc(sizeof(SV)); \
93 Safefree((char*)(p)); \
98 static I32 registry_size;
100 #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
102 #define REG_REPLACE(sv,a,b) \
104 void* p = sv->sv_any; \
105 I32 h = REGHASH(sv, registry_size); \
107 while (registry[i] != (a)) { \
108 if (++i >= registry_size) \
111 die("SV registry bug"); \
116 #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
117 #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
122 if (PL_sv_count >= (registry_size >> 1))
124 SV **oldreg = registry;
125 I32 oldsize = registry_size;
127 registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
128 Newz(707, registry, registry_size, SV*);
133 for (i = 0; i < oldsize; ++i) {
134 SV* oldsv = oldreg[i];
158 for (i = 0; i < registry_size; ++i) {
159 SV* sv = registry[i];
160 if (sv && SvTYPE(sv) != SVTYPEMASK)
166 sv_add_arena(char *ptr, U32 size, U32 flags)
168 if (!(flags & SVf_FAKE))
175 * "A time to plant, and a time to uproot what was planted..."
178 #define plant_SV(p) \
180 SvANY(p) = (void *)PL_sv_root; \
181 SvFLAGS(p) = SVTYPEMASK; \
186 /* sv_mutex must be held while calling uproot_SV() */
187 #define uproot_SV(p) \
190 PL_sv_root = (SV*)SvANY(p); \
212 if (PL_debug & 32768) \
222 if (PL_debug & 32768) {
227 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
229 svend = &sva[SvREFCNT(sva)];
230 if (p >= sv && p < svend)
234 warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
241 #else /* ! DEBUGGING */
243 #define del_SV(p) plant_SV(p)
245 #endif /* DEBUGGING */
248 sv_add_arena(char *ptr, U32 size, U32 flags)
253 Zero(sva, size, char);
255 /* The first SV in an arena isn't an SV. */
256 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
257 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
258 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
260 PL_sv_arenaroot = sva;
261 PL_sv_root = sva + 1;
263 svend = &sva[SvREFCNT(sva) - 1];
266 SvANY(sv) = (void *)(SV*)(sv + 1);
267 SvFLAGS(sv) = SVTYPEMASK;
271 SvFLAGS(sv) = SVTYPEMASK;
274 /* sv_mutex must be held while calling more_sv() */
281 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
282 PL_nice_chunk = Nullch;
285 char *chunk; /* must use New here to match call to */
286 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
287 sv_add_arena(chunk, 1008, 0);
300 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
301 svend = &sva[SvREFCNT(sva)];
302 for (sv = sva + 1; sv < svend; ++sv) {
303 if (SvTYPE(sv) != SVTYPEMASK)
312 do_report_used(SV *sv)
314 if (SvTYPE(sv) != SVTYPEMASK) {
315 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
316 PerlIO_printf(PerlIO_stderr(), "****\n");
324 visit(FUNC_NAME_TO_PTR(do_report_used));
328 do_clean_objs(SV *sv)
332 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
333 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
339 /* XXX Might want to check arrays, etc. */
342 #ifndef DISABLE_DESTRUCTOR_KLUDGE
344 do_clean_named_objs(SV *sv)
346 if (SvTYPE(sv) == SVt_PVGV) {
347 if ( SvOBJECT(GvSV(sv)) ||
348 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
349 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
350 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
351 GvCV(sv) && SvOBJECT(GvCV(sv)) )
353 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
363 PL_in_clean_objs = TRUE;
364 visit(FUNC_NAME_TO_PTR(do_clean_objs));
365 #ifndef DISABLE_DESTRUCTOR_KLUDGE
366 /* some barnacles may yet remain, clinging to typeglobs */
367 visit(FUNC_NAME_TO_PTR(do_clean_named_objs));
369 PL_in_clean_objs = FALSE;
375 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
376 SvFLAGS(sv) |= SVf_BREAK;
383 PL_in_clean_all = TRUE;
384 visit(FUNC_NAME_TO_PTR(do_clean_all));
385 PL_in_clean_all = FALSE;
394 /* Free arenas here, but be careful about fake ones. (We assume
395 contiguity of the fake ones with the corresponding real ones.) */
397 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
398 svanext = (SV*) SvANY(sva);
399 while (svanext && SvFAKE(svanext))
400 svanext = (SV*) SvANY(svanext);
403 Safefree((void *)sva);
407 Safefree(PL_nice_chunk);
408 PL_nice_chunk = Nullch;
409 PL_nice_chunk_size = 0;
423 * See comment in more_xiv() -- RAM.
425 PL_xiv_root = *(IV**)xiv;
427 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
433 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
435 *(IV**)xiv = PL_xiv_root;
446 New(705, ptr, 1008/sizeof(XPV), XPV);
447 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
448 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
451 xivend = &xiv[1008 / sizeof(IV) - 1];
452 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
454 while (xiv < xivend) {
455 *(IV**)xiv = (IV *)(xiv + 1);
469 PL_xnv_root = *(double**)xnv;
471 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
477 double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
479 *(double**)xnv = PL_xnv_root;
487 register double* xnv;
488 register double* xnvend;
489 New(711, xnv, 1008/sizeof(double), double);
490 xnvend = &xnv[1008 / sizeof(double) - 1];
491 xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */
493 while (xnv < xnvend) {
494 *(double**)xnv = (double*)(xnv + 1);
508 PL_xrv_root = (XRV*)xrv->xrv_rv;
517 p->xrv_rv = (SV*)PL_xrv_root;
526 register XRV* xrvend;
527 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
529 xrvend = &xrv[1008 / sizeof(XRV) - 1];
530 while (xrv < xrvend) {
531 xrv->xrv_rv = (SV*)(xrv + 1);
545 PL_xpv_root = (XPV*)xpv->xpv_pv;
554 p->xpv_pv = (char*)PL_xpv_root;
563 register XPV* xpvend;
564 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
566 xpvend = &xpv[1008 / sizeof(XPV) - 1];
567 while (xpv < xpvend) {
568 xpv->xpv_pv = (char*)(xpv + 1);
575 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
576 #define del_XIV(p) Safefree((char*)p)
578 #define new_XIV() (void*)new_xiv()
579 #define del_XIV(p) del_xiv((XPVIV*) p)
583 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
584 #define del_XNV(p) Safefree((char*)p)
586 #define new_XNV() (void*)new_xnv()
587 #define del_XNV(p) del_xnv((XPVNV*) p)
591 #define new_XRV() (void*)safemalloc(sizeof(XRV))
592 #define del_XRV(p) Safefree((char*)p)
594 #define new_XRV() (void*)new_xrv()
595 #define del_XRV(p) del_xrv((XRV*) p)
599 #define new_XPV() (void*)safemalloc(sizeof(XPV))
600 #define del_XPV(p) Safefree((char*)p)
602 #define new_XPV() (void*)new_xpv()
603 #define del_XPV(p) del_xpv((XPV *)p)
607 # define my_safemalloc(s) safemalloc(s)
608 # define my_safefree(s) safefree(s)
611 my_safemalloc(MEM_SIZE size)
614 New(717, p, size, char);
617 # define my_safefree(s) Safefree(s)
620 #define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
621 #define del_XPVIV(p) my_safefree((char*)p)
623 #define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
624 #define del_XPVNV(p) my_safefree((char*)p)
626 #define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
627 #define del_XPVMG(p) my_safefree((char*)p)
629 #define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
630 #define del_XPVLV(p) my_safefree((char*)p)
632 #define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
633 #define del_XPVAV(p) my_safefree((char*)p)
635 #define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
636 #define del_XPVHV(p) my_safefree((char*)p)
638 #define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
639 #define del_XPVCV(p) my_safefree((char*)p)
641 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
642 #define del_XPVGV(p) my_safefree((char*)p)
644 #define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
645 #define del_XPVBM(p) my_safefree((char*)p)
647 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
648 #define del_XPVFM(p) my_safefree((char*)p)
650 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
651 #define del_XPVIO(p) my_safefree((char*)p)
654 sv_upgrade(register SV *sv, U32 mt)
664 if (SvTYPE(sv) == mt)
670 switch (SvTYPE(sv)) {
685 nv = (double)SvIVX(sv);
691 else if (mt < SVt_PVIV)
708 pv = (char*)SvRV(sv);
712 nv = (double)(unsigned long)pv;
728 else if (mt == SVt_NV)
739 del_XPVIV(SvANY(sv));
749 del_XPVNV(SvANY(sv));
759 del_XPVMG(SvANY(sv));
762 croak("Can't upgrade that kind of scalar");
767 croak("Can't upgrade to undef");
769 SvANY(sv) = new_XIV();
773 SvANY(sv) = new_XNV();
777 SvANY(sv) = new_XRV();
781 SvANY(sv) = new_XPV();
787 SvANY(sv) = new_XPVIV();
797 SvANY(sv) = new_XPVNV();
805 SvANY(sv) = new_XPVMG();
815 SvANY(sv) = new_XPVLV();
829 SvANY(sv) = new_XPVAV();
844 SvANY(sv) = new_XPVHV();
860 SvANY(sv) = new_XPVCV();
861 Zero(SvANY(sv), 1, XPVCV);
871 SvANY(sv) = new_XPVGV();
886 SvANY(sv) = new_XPVBM();
899 SvANY(sv) = new_XPVFM();
900 Zero(SvANY(sv), 1, XPVFM);
910 SvANY(sv) = new_XPVIO();
911 Zero(SvANY(sv), 1, XPVIO);
922 SvFLAGS(sv) &= ~SVTYPEMASK;
928 sv_backoff(register SV *sv)
933 SvLEN(sv) += SvIVX(sv);
934 SvPVX(sv) -= SvIVX(sv);
936 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
938 SvFLAGS(sv) &= ~SVf_OOK;
943 sv_grow(register SV *sv, register STRLEN newlen)
948 if (newlen >= 0x10000) {
949 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
952 #endif /* HAS_64K_LIMIT */
955 if (SvTYPE(sv) < SVt_PV) {
956 sv_upgrade(sv, SVt_PV);
959 else if (SvOOK(sv)) { /* pv is offset? */
962 if (newlen > SvLEN(sv))
963 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
965 if (newlen >= 0x10000)
971 if (newlen > SvLEN(sv)) { /* need more room? */
972 if (SvLEN(sv) && s) {
973 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
974 STRLEN l = malloced_size((void*)SvPVX(sv));
980 Renew(s,newlen,char);
983 New(703,s,newlen,char);
985 SvLEN_set(sv, newlen);
991 sv_setiv(register SV *sv, IV i)
993 SV_CHECK_THINKFIRST(sv);
994 switch (SvTYPE(sv)) {
996 sv_upgrade(sv, SVt_IV);
999 sv_upgrade(sv, SVt_PVNV);
1003 sv_upgrade(sv, SVt_PVIV);
1014 croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
1015 PL_op_desc[PL_op->op_type]);
1018 (void)SvIOK_only(sv); /* validate number */
1024 sv_setiv_mg(register SV *sv, IV i)
1031 sv_setuv(register SV *sv, UV u)
1039 sv_setuv_mg(register SV *sv, UV u)
1046 sv_setnv(register SV *sv, double num)
1048 SV_CHECK_THINKFIRST(sv);
1049 switch (SvTYPE(sv)) {
1052 sv_upgrade(sv, SVt_NV);
1057 sv_upgrade(sv, SVt_PVNV);
1068 croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
1069 PL_op_name[PL_op->op_type]);
1073 (void)SvNOK_only(sv); /* validate number */
1078 sv_setnv_mg(register SV *sv, double num)
1085 not_a_number(SV *sv)
1091 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1092 /* each *s can expand to 4 chars + "...\0",
1093 i.e. need room for 8 chars */
1095 for (s = SvPVX(sv); *s && d < limit; s++) {
1097 if (ch & 128 && !isPRINT_LC(ch)) {
1106 else if (ch == '\r') {
1110 else if (ch == '\f') {
1114 else if (ch == '\\') {
1118 else if (isPRINT_LC(ch))
1133 warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
1134 PL_op_name[PL_op->op_type]);
1136 warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
1139 /* the number can be converted to _integer_ with atol() */
1140 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1141 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1142 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1143 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1145 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1146 until proven guilty, assume that things are not that bad... */
1149 sv_2iv(register SV *sv)
1153 if (SvGMAGICAL(sv)) {
1158 return I_V(SvNVX(sv));
1160 if (SvPOKp(sv) && SvLEN(sv))
1163 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1165 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1166 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1171 if (SvTHINKFIRST(sv)) {
1174 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1175 return SvIV(tmpstr);
1176 return (IV)SvRV(sv);
1178 if (SvREADONLY(sv)) {
1180 return I_V(SvNVX(sv));
1182 if (SvPOKp(sv) && SvLEN(sv))
1186 if (ckWARN(WARN_UNINITIALIZED))
1187 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1194 return (IV)(SvUVX(sv));
1201 /* We can cache the IV/UV value even if it not good enough
1202 * to reconstruct NV, since the conversion to PV will prefer
1203 * NV over IV/UV. XXXX 64-bit?
1206 if (SvTYPE(sv) == SVt_NV)
1207 sv_upgrade(sv, SVt_PVNV);
1210 if (SvNVX(sv) < (double)IV_MAX + 0.5)
1211 SvIVX(sv) = I_V(SvNVX(sv));
1213 SvUVX(sv) = U_V(SvNVX(sv));
1216 DEBUG_c(PerlIO_printf(Perl_debug_log,
1217 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1219 (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
1220 return (IV)SvUVX(sv);
1223 else if (SvPOKp(sv) && SvLEN(sv)) {
1224 I32 numtype = looks_like_number(sv);
1226 /* We want to avoid a possible problem when we cache an IV which
1227 may be later translated to an NV, and the resulting NV is not
1228 the translation of the initial data.
1230 This means that if we cache such an IV, we need to cache the
1231 NV as well. Moreover, we trade speed for space, and do not
1232 cache the NV if not needed.
1234 if (numtype & IS_NUMBER_NOT_IV) {
1235 /* May be not an integer. Need to cache NV if we cache IV
1236 * - otherwise future conversion to NV will be wrong. */
1239 SET_NUMERIC_STANDARD();
1240 d = atof(SvPVX(sv));
1242 if (SvTYPE(sv) < SVt_PVNV)
1243 sv_upgrade(sv, SVt_PVNV);
1247 DEBUG_c(PerlIO_printf(Perl_debug_log,
1248 "0x%lx 2nv(%g)\n",(unsigned long)sv,
1250 if (SvNVX(sv) < (double)IV_MAX + 0.5)
1251 SvIVX(sv) = I_V(SvNVX(sv));
1253 SvUVX(sv) = U_V(SvNVX(sv));
1259 /* The NV may be reconstructed from IV - safe to cache IV,
1260 which may be calculated by atol(). */
1261 if (SvTYPE(sv) == SVt_PV)
1262 sv_upgrade(sv, SVt_PVIV);
1264 SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
1266 else { /* Not a number. Cache 0. */
1269 if (SvTYPE(sv) < SVt_PVIV)
1270 sv_upgrade(sv, SVt_PVIV);
1273 if (ckWARN(WARN_NUMERIC))
1279 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1280 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1281 if (SvTYPE(sv) < SVt_IV)
1282 /* Typically the caller expects that sv_any is not NULL now. */
1283 sv_upgrade(sv, SVt_IV);
1286 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1287 (unsigned long)sv,(long)SvIVX(sv)));
1288 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1292 sv_2uv(register SV *sv)
1296 if (SvGMAGICAL(sv)) {
1301 return U_V(SvNVX(sv));
1302 if (SvPOKp(sv) && SvLEN(sv))
1305 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1307 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1308 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1313 if (SvTHINKFIRST(sv)) {
1316 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1317 return SvUV(tmpstr);
1318 return (UV)SvRV(sv);
1320 if (SvREADONLY(sv)) {
1322 return U_V(SvNVX(sv));
1324 if (SvPOKp(sv) && SvLEN(sv))
1328 if (ckWARN(WARN_UNINITIALIZED))
1329 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1339 return (UV)SvIVX(sv);
1343 /* We can cache the IV/UV value even if it not good enough
1344 * to reconstruct NV, since the conversion to PV will prefer
1345 * NV over IV/UV. XXXX 64-bit?
1347 if (SvTYPE(sv) == SVt_NV)
1348 sv_upgrade(sv, SVt_PVNV);
1350 if (SvNVX(sv) >= -0.5) {
1352 SvUVX(sv) = U_V(SvNVX(sv));
1355 SvIVX(sv) = I_V(SvNVX(sv));
1357 DEBUG_c(PerlIO_printf(Perl_debug_log,
1358 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1359 (unsigned long)sv,(long)SvIVX(sv),
1360 (long)(UV)SvIVX(sv)));
1361 return (UV)SvIVX(sv);
1364 else if (SvPOKp(sv) && SvLEN(sv)) {
1365 I32 numtype = looks_like_number(sv);
1367 /* We want to avoid a possible problem when we cache a UV which
1368 may be later translated to an NV, and the resulting NV is not
1369 the translation of the initial data.
1371 This means that if we cache such a UV, we need to cache the
1372 NV as well. Moreover, we trade speed for space, and do not
1373 cache the NV if not needed.
1375 if (numtype & IS_NUMBER_NOT_IV) {
1376 /* May be not an integer. Need to cache NV if we cache IV
1377 * - otherwise future conversion to NV will be wrong. */
1380 SET_NUMERIC_STANDARD();
1381 d = atof(SvPVX(sv)); /* XXXX 64-bit? */
1383 if (SvTYPE(sv) < SVt_PVNV)
1384 sv_upgrade(sv, SVt_PVNV);
1388 DEBUG_c(PerlIO_printf(Perl_debug_log,
1389 "0x%lx 2nv(%g)\n",(unsigned long)sv,
1391 if (SvNVX(sv) < -0.5) {
1392 SvIVX(sv) = I_V(SvNVX(sv));
1395 SvUVX(sv) = U_V(SvNVX(sv));
1399 else if (numtype & IS_NUMBER_NEG) {
1400 /* The NV may be reconstructed from IV - safe to cache IV,
1401 which may be calculated by atol(). */
1402 if (SvTYPE(sv) == SVt_PV)
1403 sv_upgrade(sv, SVt_PVIV);
1405 SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1407 else if (numtype) { /* Non-negative */
1408 /* The NV may be reconstructed from UV - safe to cache UV,
1409 which may be calculated by strtoul()/atol. */
1410 if (SvTYPE(sv) == SVt_PV)
1411 sv_upgrade(sv, SVt_PVIV);
1413 (void)SvIsUV_on(sv);
1415 SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
1416 #else /* no atou(), but we know the number fits into IV... */
1417 /* The only problem may be if it is negative... */
1418 SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1421 else { /* Not a number. Cache 0. */
1424 if (SvTYPE(sv) < SVt_PVIV)
1425 sv_upgrade(sv, SVt_PVIV);
1426 SvUVX(sv) = 0; /* We assume that 0s have the
1427 same bitmap in IV and UV. */
1429 (void)SvIsUV_on(sv);
1430 if (ckWARN(WARN_NUMERIC))
1435 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1437 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1438 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1440 if (SvTYPE(sv) < SVt_IV)
1441 /* Typically the caller expects that sv_any is not NULL now. */
1442 sv_upgrade(sv, SVt_IV);
1446 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1447 (unsigned long)sv,SvUVX(sv)));
1448 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1452 sv_2nv(register SV *sv)
1456 if (SvGMAGICAL(sv)) {
1460 if (SvPOKp(sv) && SvLEN(sv)) {
1462 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1464 SET_NUMERIC_STANDARD();
1465 return atof(SvPVX(sv));
1469 return (double)SvUVX(sv);
1471 return (double)SvIVX(sv);
1474 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1476 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1477 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1482 if (SvTHINKFIRST(sv)) {
1485 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1486 return SvNV(tmpstr);
1487 return (double)(unsigned long)SvRV(sv);
1489 if (SvREADONLY(sv)) {
1491 if (SvPOKp(sv) && SvLEN(sv)) {
1492 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1494 SET_NUMERIC_STANDARD();
1495 return atof(SvPVX(sv));
1499 return (double)SvUVX(sv);
1501 return (double)SvIVX(sv);
1503 if (ckWARN(WARN_UNINITIALIZED))
1504 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1508 if (SvTYPE(sv) < SVt_NV) {
1509 if (SvTYPE(sv) == SVt_IV)
1510 sv_upgrade(sv, SVt_PVNV);
1512 sv_upgrade(sv, SVt_NV);
1513 DEBUG_c(SET_NUMERIC_STANDARD());
1514 DEBUG_c(PerlIO_printf(Perl_debug_log,
1515 "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
1517 else if (SvTYPE(sv) < SVt_PVNV)
1518 sv_upgrade(sv, SVt_PVNV);
1520 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1522 SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv);
1524 else if (SvPOKp(sv) && SvLEN(sv)) {
1526 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1528 SET_NUMERIC_STANDARD();
1529 SvNVX(sv) = atof(SvPVX(sv));
1533 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1534 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1535 if (SvTYPE(sv) < SVt_NV)
1536 /* Typically the caller expects that sv_any is not NULL now. */
1537 sv_upgrade(sv, SVt_NV);
1541 DEBUG_c(SET_NUMERIC_STANDARD());
1542 DEBUG_c(PerlIO_printf(Perl_debug_log,
1543 "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
1550 I32 numtype = looks_like_number(sv);
1553 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1554 return atol(SvPVX(sv)); /* XXXX 64-bit? */
1557 if (ckWARN(WARN_NUMERIC))
1560 SET_NUMERIC_STANDARD();
1561 d = atof(SvPVX(sv));
1568 I32 numtype = looks_like_number(sv);
1571 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1572 return strtoul(SvPVX(sv), Null(char**), 10);
1576 if (ckWARN(WARN_NUMERIC))
1579 SET_NUMERIC_STANDARD();
1580 return U_V(atof(SvPVX(sv)));
1584 * Returns a combination of (advisory only - can get false negatives)
1585 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1587 * 0 if does not look like number.
1589 * In fact possible values are 0 and
1590 * IS_NUMBER_TO_INT_BY_ATOL 123
1591 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1592 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1593 * with a possible addition of IS_NUMBER_NEG.
1597 looks_like_number(SV *sv)
1599 /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
1600 * using atof() may lose precision. */
1602 register char *send;
1603 register char *sbegin;
1604 register char *nbegin;
1612 else if (SvPOKp(sv))
1613 sbegin = SvPV(sv, len);
1616 send = sbegin + len;
1623 numtype = IS_NUMBER_NEG;
1630 * we return 1 if the number can be converted to _integer_ with atol()
1631 * and 2 if you need (int)atof().
1634 /* next must be digit or '.' */
1638 } while (isDIGIT(*s));
1640 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1641 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1643 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1647 numtype |= IS_NUMBER_NOT_IV;
1648 while (isDIGIT(*s)) /* optional digits after "." */
1652 else if (*s == '.') {
1654 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1655 /* no digits before '.' means we need digits after it */
1659 } while (isDIGIT(*s));
1667 /* we can have an optional exponent part */
1668 if (*s == 'e' || *s == 'E') {
1669 numtype &= ~IS_NUMBER_NEG;
1670 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1672 if (*s == '+' || *s == '-')
1677 } while (isDIGIT(*s));
1686 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1687 return IS_NUMBER_TO_INT_BY_ATOL;
1692 sv_2pv_nolen(register SV *sv)
1695 return sv_2pv(sv, &n_a);
1698 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1700 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1703 char *ptr = buf + TYPE_CHARS(UV);
1718 *--ptr = '0' + (uv % 10);
1727 sv_2pv(register SV *sv, STRLEN *lp)
1732 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1733 char *tmpbuf = tbuf;
1739 if (SvGMAGICAL(sv)) {
1745 if (SvIOKp(sv)) { /* XXXX 64-bit? */
1747 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1749 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1754 SET_NUMERIC_STANDARD();
1755 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1760 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1762 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1763 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1769 if (SvTHINKFIRST(sv)) {
1772 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1773 return SvPV(tmpstr,*lp);
1780 switch (SvTYPE(sv)) {
1782 if ( ((SvFLAGS(sv) &
1783 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1784 == (SVs_OBJECT|SVs_RMG))
1785 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1786 && (mg = mg_find(sv, 'r'))) {
1788 regexp *re = (regexp *)mg->mg_obj;
1791 char *fptr = "msix";
1796 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1798 while(ch = *fptr++) {
1800 reflags[left++] = ch;
1803 reflags[right--] = ch;
1808 reflags[left] = '-';
1812 mg->mg_len = re->prelen + 4 + left;
1813 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1814 Copy("(?", mg->mg_ptr, 2, char);
1815 Copy(reflags, mg->mg_ptr+2, left, char);
1816 Copy(":", mg->mg_ptr+left+2, 1, char);
1817 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1818 mg->mg_ptr[mg->mg_len - 1] = ')';
1819 mg->mg_ptr[mg->mg_len] = 0;
1821 PL_reginterp_cnt += re->program[0].next_off;
1833 case SVt_PVBM: s = "SCALAR"; break;
1834 case SVt_PVLV: s = "LVALUE"; break;
1835 case SVt_PVAV: s = "ARRAY"; break;
1836 case SVt_PVHV: s = "HASH"; break;
1837 case SVt_PVCV: s = "CODE"; break;
1838 case SVt_PVGV: s = "GLOB"; break;
1839 case SVt_PVFM: s = "FORMAT"; break;
1840 case SVt_PVIO: s = "IO"; break;
1841 default: s = "UNKNOWN"; break;
1845 sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1849 sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
1855 if (SvREADONLY(sv)) {
1856 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1857 /* XXXX 64-bit? IV may have better precision... */
1858 SET_NUMERIC_STANDARD();
1859 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1867 tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
1869 tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
1876 if (ckWARN(WARN_UNINITIALIZED))
1877 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1883 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1884 /* XXXX 64-bit? IV may have better precision... */
1885 if (SvTYPE(sv) < SVt_PVNV)
1886 sv_upgrade(sv, SVt_PVNV);
1889 olderrno = errno; /* some Xenix systems wipe out errno here */
1891 if (SvNVX(sv) == 0.0)
1892 (void)strcpy(s,"0");
1896 SET_NUMERIC_STANDARD();
1897 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1900 #ifdef FIXNEGATIVEZERO
1901 if (*s == '-' && s[1] == '0' && !s[2])
1910 else if (SvIOKp(sv)) {
1911 U32 isIOK = SvIOK(sv);
1912 char buf[TYPE_CHARS(UV)];
1915 if (SvTYPE(sv) < SVt_PVIV)
1916 sv_upgrade(sv, SVt_PVIV);
1918 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1919 sv_setpvn(sv, ptr, ebuf - ptr);
1923 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1924 sv_setpvn(sv, ptr, ebuf - ptr);
1934 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1935 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1937 if (SvTYPE(sv) < SVt_PV)
1938 /* Typically the caller expects that sv_any is not NULL now. */
1939 sv_upgrade(sv, SVt_PV);
1942 *lp = s - SvPVX(sv);
1945 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1949 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1950 /* Sneaky stuff here */
1954 tsv = newSVpv(tmpbuf, 0);
1970 len = strlen(tmpbuf);
1972 #ifdef FIXNEGATIVEZERO
1973 if (len == 2 && t[0] == '-' && t[1] == '0') {
1978 (void)SvUPGRADE(sv, SVt_PV);
1980 s = SvGROW(sv, len + 1);
1988 /* This function is only called on magical items */
1990 sv_2bool(register SV *sv)
2000 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2001 return SvTRUE(tmpsv);
2002 return SvRV(sv) != 0;
2005 register XPV* Xpvtmp;
2006 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2007 (*Xpvtmp->xpv_pv > '0' ||
2008 Xpvtmp->xpv_cur > 1 ||
2009 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2016 return SvIVX(sv) != 0;
2019 return SvNVX(sv) != 0.0;
2026 /* Note: sv_setsv() should not be called with a source string that needs
2027 * to be reused, since it may destroy the source string if it is marked
2032 sv_setsv(SV *dstr, register SV *sstr)
2035 register U32 sflags;
2041 SV_CHECK_THINKFIRST(dstr);
2043 sstr = &PL_sv_undef;
2044 stype = SvTYPE(sstr);
2045 dtype = SvTYPE(dstr);
2049 /* There's a lot of redundancy below but we're going for speed here */
2054 if (dtype != SVt_PVGV) {
2055 (void)SvOK_off(dstr);
2063 sv_upgrade(dstr, SVt_IV);
2066 sv_upgrade(dstr, SVt_PVNV);
2070 sv_upgrade(dstr, SVt_PVIV);
2073 (void)SvIOK_only(dstr);
2074 SvIVX(dstr) = SvIVX(sstr);
2087 sv_upgrade(dstr, SVt_NV);
2092 sv_upgrade(dstr, SVt_PVNV);
2095 SvNVX(dstr) = SvNVX(sstr);
2096 (void)SvNOK_only(dstr);
2104 sv_upgrade(dstr, SVt_RV);
2105 else if (dtype == SVt_PVGV &&
2106 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2109 if (PL_curcop->cop_stash != GvSTASH(dstr))
2110 GvIMPORTED_on(dstr);
2120 sv_upgrade(dstr, SVt_PV);
2123 if (dtype < SVt_PVIV)
2124 sv_upgrade(dstr, SVt_PVIV);
2127 if (dtype < SVt_PVNV)
2128 sv_upgrade(dstr, SVt_PVNV);
2135 croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2136 PL_op_name[PL_op->op_type]);
2138 croak("Bizarre copy of %s", sv_reftype(sstr, 0));
2142 if (dtype <= SVt_PVGV) {
2144 if (dtype != SVt_PVGV) {
2145 char *name = GvNAME(sstr);
2146 STRLEN len = GvNAMELEN(sstr);
2147 sv_upgrade(dstr, SVt_PVGV);
2148 sv_magic(dstr, dstr, '*', name, len);
2149 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2150 GvNAME(dstr) = savepvn(name, len);
2151 GvNAMELEN(dstr) = len;
2152 SvFAKE_on(dstr); /* can coerce to non-glob */
2154 /* ahem, death to those who redefine active sort subs */
2155 else if (PL_curstackinfo->si_type == PERLSI_SORT
2156 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2157 croak("Can't redefine active sort subroutine %s",
2159 (void)SvOK_off(dstr);
2160 GvINTRO_off(dstr); /* one-shot flag */
2162 GvGP(dstr) = gp_ref(GvGP(sstr));
2164 if (PL_curcop->cop_stash != GvSTASH(dstr))
2165 GvIMPORTED_on(dstr);
2172 if (SvGMAGICAL(sstr)) {
2174 if (SvTYPE(sstr) != stype) {
2175 stype = SvTYPE(sstr);
2176 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2180 if (stype == SVt_PVLV)
2181 (void)SvUPGRADE(dstr, SVt_PVNV);
2183 (void)SvUPGRADE(dstr, stype);
2186 sflags = SvFLAGS(sstr);
2188 if (sflags & SVf_ROK) {
2189 if (dtype >= SVt_PV) {
2190 if (dtype == SVt_PVGV) {
2191 SV *sref = SvREFCNT_inc(SvRV(sstr));
2193 int intro = GvINTRO(dstr);
2197 GvGP(dstr)->gp_refcnt--;
2198 GvINTRO_off(dstr); /* one-shot flag */
2199 Newz(602,gp, 1, GP);
2200 GvGP(dstr) = gp_ref(gp);
2201 GvSV(dstr) = NEWSV(72,0);
2202 GvLINE(dstr) = PL_curcop->cop_line;
2203 GvEGV(dstr) = (GV*)dstr;
2206 switch (SvTYPE(sref)) {
2209 SAVESPTR(GvAV(dstr));
2211 dref = (SV*)GvAV(dstr);
2212 GvAV(dstr) = (AV*)sref;
2213 if (PL_curcop->cop_stash != GvSTASH(dstr))
2214 GvIMPORTED_AV_on(dstr);
2218 SAVESPTR(GvHV(dstr));
2220 dref = (SV*)GvHV(dstr);
2221 GvHV(dstr) = (HV*)sref;
2222 if (PL_curcop->cop_stash != GvSTASH(dstr))
2223 GvIMPORTED_HV_on(dstr);
2227 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2228 SvREFCNT_dec(GvCV(dstr));
2229 GvCV(dstr) = Nullcv;
2230 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2231 PL_sub_generation++;
2233 SAVESPTR(GvCV(dstr));
2236 dref = (SV*)GvCV(dstr);
2237 if (GvCV(dstr) != (CV*)sref) {
2238 CV* cv = GvCV(dstr);
2240 if (!GvCVGEN((GV*)dstr) &&
2241 (CvROOT(cv) || CvXSUB(cv)))
2243 SV *const_sv = cv_const_sv(cv);
2244 bool const_changed = TRUE;
2246 const_changed = sv_cmp(const_sv,
2247 op_const_sv(CvSTART((CV*)sref),
2249 /* ahem, death to those who redefine
2250 * active sort subs */
2251 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2252 PL_sortcop == CvSTART(cv))
2254 "Can't redefine active sort subroutine %s",
2255 GvENAME((GV*)dstr));
2256 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2257 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2258 && HvNAME(GvSTASH(CvGV(cv)))
2259 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2261 warner(WARN_REDEFINE, const_sv ?
2262 "Constant subroutine %s redefined"
2263 : "Subroutine %s redefined",
2264 GvENAME((GV*)dstr));
2267 cv_ckproto(cv, (GV*)dstr,
2268 SvPOK(sref) ? SvPVX(sref) : Nullch);
2270 GvCV(dstr) = (CV*)sref;
2271 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2272 GvASSUMECV_on(dstr);
2273 PL_sub_generation++;
2275 if (PL_curcop->cop_stash != GvSTASH(dstr))
2276 GvIMPORTED_CV_on(dstr);
2280 SAVESPTR(GvIOp(dstr));
2282 dref = (SV*)GvIOp(dstr);
2283 GvIOp(dstr) = (IO*)sref;
2287 SAVESPTR(GvSV(dstr));
2289 dref = (SV*)GvSV(dstr);
2291 if (PL_curcop->cop_stash != GvSTASH(dstr))
2292 GvIMPORTED_SV_on(dstr);
2303 (void)SvOOK_off(dstr); /* backoff */
2305 Safefree(SvPVX(dstr));
2306 SvLEN(dstr)=SvCUR(dstr)=0;
2309 (void)SvOK_off(dstr);
2310 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2312 if (sflags & SVp_NOK) {
2314 SvNVX(dstr) = SvNVX(sstr);
2316 if (sflags & SVp_IOK) {
2317 (void)SvIOK_on(dstr);
2318 SvIVX(dstr) = SvIVX(sstr);
2322 if (SvAMAGIC(sstr)) {
2326 else if (sflags & SVp_POK) {
2329 * Check to see if we can just swipe the string. If so, it's a
2330 * possible small lose on short strings, but a big win on long ones.
2331 * It might even be a win on short strings if SvPVX(dstr)
2332 * has to be allocated and SvPVX(sstr) has to be freed.
2335 if (SvTEMP(sstr) && /* slated for free anyway? */
2336 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2337 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2339 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2341 SvFLAGS(dstr) &= ~SVf_OOK;
2342 Safefree(SvPVX(dstr) - SvIVX(dstr));
2344 else if (SvLEN(dstr))
2345 Safefree(SvPVX(dstr));
2347 (void)SvPOK_only(dstr);
2348 SvPV_set(dstr, SvPVX(sstr));
2349 SvLEN_set(dstr, SvLEN(sstr));
2350 SvCUR_set(dstr, SvCUR(sstr));
2352 (void)SvOK_off(sstr);
2353 SvPV_set(sstr, Nullch);
2358 else { /* have to copy actual string */
2359 STRLEN len = SvCUR(sstr);
2361 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2362 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2363 SvCUR_set(dstr, len);
2364 *SvEND(dstr) = '\0';
2365 (void)SvPOK_only(dstr);
2368 if (sflags & SVp_NOK) {
2370 SvNVX(dstr) = SvNVX(sstr);
2372 if (sflags & SVp_IOK) {
2373 (void)SvIOK_on(dstr);
2374 SvIVX(dstr) = SvIVX(sstr);
2379 else if (sflags & SVp_NOK) {
2380 SvNVX(dstr) = SvNVX(sstr);
2381 (void)SvNOK_only(dstr);
2383 (void)SvIOK_on(dstr);
2384 SvIVX(dstr) = SvIVX(sstr);
2385 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2390 else if (sflags & SVp_IOK) {
2391 (void)SvIOK_only(dstr);
2392 SvIVX(dstr) = SvIVX(sstr);
2397 if (dtype == SVt_PVGV) {
2398 if (ckWARN(WARN_UNSAFE))
2399 warner(WARN_UNSAFE, "Undefined value assigned to typeglob");
2402 (void)SvOK_off(dstr);
2408 sv_setsv_mg(SV *dstr, register SV *sstr)
2410 sv_setsv(dstr,sstr);
2415 sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len)
2417 register char *dptr;
2418 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2419 elicit a warning, but it won't hurt. */
2420 SV_CHECK_THINKFIRST(sv);
2425 (void)SvUPGRADE(sv, SVt_PV);
2427 SvGROW(sv, len + 1);
2429 Move(ptr,dptr,len,char);
2432 (void)SvPOK_only(sv); /* validate pointer */
2437 sv_setpvn_mg(register SV *sv, register const char *ptr, register STRLEN len)
2439 sv_setpvn(sv,ptr,len);
2444 sv_setpv(register SV *sv, register const char *ptr)
2446 register STRLEN len;
2448 SV_CHECK_THINKFIRST(sv);
2454 (void)SvUPGRADE(sv, SVt_PV);
2456 SvGROW(sv, len + 1);
2457 Move(ptr,SvPVX(sv),len+1,char);
2459 (void)SvPOK_only(sv); /* validate pointer */
2464 sv_setpv_mg(register SV *sv, register const char *ptr)
2471 sv_usepvn(register SV *sv, register char *ptr, register STRLEN len)
2473 SV_CHECK_THINKFIRST(sv);
2474 (void)SvUPGRADE(sv, SVt_PV);
2479 (void)SvOOK_off(sv);
2480 if (SvPVX(sv) && SvLEN(sv))
2481 Safefree(SvPVX(sv));
2482 Renew(ptr, len+1, char);
2485 SvLEN_set(sv, len+1);
2487 (void)SvPOK_only(sv); /* validate pointer */
2492 sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len)
2494 sv_usepvn(sv,ptr,len);
2499 sv_force_normal(register SV *sv)
2501 if (SvREADONLY(sv)) {
2503 if (PL_curcop != &PL_compiling)
2504 croak(PL_no_modify);
2508 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2513 sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2517 register STRLEN delta;
2519 if (!ptr || !SvPOKp(sv))
2521 SV_CHECK_THINKFIRST(sv);
2522 if (SvTYPE(sv) < SVt_PVIV)
2523 sv_upgrade(sv,SVt_PVIV);
2526 if (!SvLEN(sv)) { /* make copy of shared string */
2527 char *pvx = SvPVX(sv);
2528 STRLEN len = SvCUR(sv);
2529 SvGROW(sv, len + 1);
2530 Move(pvx,SvPVX(sv),len,char);
2534 SvFLAGS(sv) |= SVf_OOK;
2536 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2537 delta = ptr - SvPVX(sv);
2545 sv_catpvn(register SV *sv, register const char *ptr, register STRLEN len)
2550 junk = SvPV_force(sv, tlen);
2551 SvGROW(sv, tlen + len + 1);
2554 Move(ptr,SvPVX(sv)+tlen,len,char);
2557 (void)SvPOK_only(sv); /* validate pointer */
2562 sv_catpvn_mg(register SV *sv, register const char *ptr, register STRLEN len)
2564 sv_catpvn(sv,ptr,len);
2569 sv_catsv(SV *dstr, register SV *sstr)
2575 if (s = SvPV(sstr, len))
2576 sv_catpvn(dstr,s,len);
2580 sv_catsv_mg(SV *dstr, register SV *sstr)
2582 sv_catsv(dstr,sstr);
2587 sv_catpv(register SV *sv, register const char *ptr)
2589 register STRLEN len;
2595 junk = SvPV_force(sv, tlen);
2597 SvGROW(sv, tlen + len + 1);
2600 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2602 (void)SvPOK_only(sv); /* validate pointer */
2607 sv_catpv_mg(register SV *sv, register const char *ptr)
2620 sv_upgrade(sv, SVt_PV);
2621 SvGROW(sv, len + 1);
2626 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2629 sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2633 if (SvREADONLY(sv)) {
2635 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2636 croak(PL_no_modify);
2638 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2639 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2646 (void)SvUPGRADE(sv, SVt_PVMG);
2648 Newz(702,mg, 1, MAGIC);
2649 mg->mg_moremagic = SvMAGIC(sv);
2652 if (!obj || obj == sv || how == '#' || how == 'r')
2656 mg->mg_obj = SvREFCNT_inc(obj);
2657 mg->mg_flags |= MGf_REFCOUNTED;
2660 mg->mg_len = namlen;
2663 mg->mg_ptr = savepvn(name, namlen);
2664 else if (namlen == HEf_SVKEY)
2665 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2669 mg->mg_virtual = &PL_vtbl_sv;
2672 mg->mg_virtual = &PL_vtbl_amagic;
2675 mg->mg_virtual = &PL_vtbl_amagicelem;
2681 mg->mg_virtual = &PL_vtbl_bm;
2684 mg->mg_virtual = &PL_vtbl_regdata;
2687 mg->mg_virtual = &PL_vtbl_regdatum;
2690 mg->mg_virtual = &PL_vtbl_env;
2693 mg->mg_virtual = &PL_vtbl_fm;
2696 mg->mg_virtual = &PL_vtbl_envelem;
2699 mg->mg_virtual = &PL_vtbl_mglob;
2702 mg->mg_virtual = &PL_vtbl_isa;
2705 mg->mg_virtual = &PL_vtbl_isaelem;
2708 mg->mg_virtual = &PL_vtbl_nkeys;
2715 mg->mg_virtual = &PL_vtbl_dbline;
2719 mg->mg_virtual = &PL_vtbl_mutex;
2721 #endif /* USE_THREADS */
2722 #ifdef USE_LOCALE_COLLATE
2724 mg->mg_virtual = &PL_vtbl_collxfrm;
2726 #endif /* USE_LOCALE_COLLATE */
2728 mg->mg_virtual = &PL_vtbl_pack;
2732 mg->mg_virtual = &PL_vtbl_packelem;
2735 mg->mg_virtual = &PL_vtbl_regexp;
2738 mg->mg_virtual = &PL_vtbl_sig;
2741 mg->mg_virtual = &PL_vtbl_sigelem;
2744 mg->mg_virtual = &PL_vtbl_taint;
2748 mg->mg_virtual = &PL_vtbl_uvar;
2751 mg->mg_virtual = &PL_vtbl_vec;
2754 mg->mg_virtual = &PL_vtbl_substr;
2757 mg->mg_virtual = &PL_vtbl_defelem;
2760 mg->mg_virtual = &PL_vtbl_glob;
2763 mg->mg_virtual = &PL_vtbl_arylen;
2766 mg->mg_virtual = &PL_vtbl_pos;
2769 mg->mg_virtual = &PL_vtbl_backref;
2771 case '~': /* Reserved for use by extensions not perl internals. */
2772 /* Useful for attaching extension internal data to perl vars. */
2773 /* Note that multiple extensions may clash if magical scalars */
2774 /* etc holding private data from one are passed to another. */
2778 croak("Don't know how to handle magic of type '%c'", how);
2782 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2786 sv_unmagic(SV *sv, int type)
2790 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2793 for (mg = *mgp; mg; mg = *mgp) {
2794 if (mg->mg_type == type) {
2795 MGVTBL* vtbl = mg->mg_virtual;
2796 *mgp = mg->mg_moremagic;
2797 if (vtbl && (vtbl->svt_free != NULL))
2798 (VTBL->svt_free)(sv, mg);
2799 if (mg->mg_ptr && mg->mg_type != 'g')
2800 if (mg->mg_len >= 0)
2801 Safefree(mg->mg_ptr);
2802 else if (mg->mg_len == HEf_SVKEY)
2803 SvREFCNT_dec((SV*)mg->mg_ptr);
2804 if (mg->mg_flags & MGf_REFCOUNTED)
2805 SvREFCNT_dec(mg->mg_obj);
2809 mgp = &mg->mg_moremagic;
2813 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2823 if (!SvOK(sv)) /* let undefs pass */
2826 croak("Can't weaken a nonreference");
2827 else if (SvWEAKREF(sv)) {
2829 if (ckWARN(WARN_MISC))
2830 warner(WARN_MISC, "Reference is already weak");
2834 sv_add_backref(tsv, sv);
2841 sv_add_backref(SV *tsv, SV *sv)
2845 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2846 av = (AV*)mg->mg_obj;
2849 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2850 SvREFCNT_dec(av); /* for sv_magic */
2856 sv_del_backref(SV *sv)
2863 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2864 croak("panic: del_backref");
2865 av = (AV *)mg->mg_obj;
2870 svp[i] = &PL_sv_undef; /* XXX */
2877 sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2881 register char *midend;
2882 register char *bigend;
2888 croak("Can't modify non-existent substring");
2889 SvPV_force(bigstr, curlen);
2890 if (offset + len > curlen) {
2891 SvGROW(bigstr, offset+len+1);
2892 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2893 SvCUR_set(bigstr, offset+len);
2896 i = littlelen - len;
2897 if (i > 0) { /* string might grow */
2898 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2899 mid = big + offset + len;
2900 midend = bigend = big + SvCUR(bigstr);
2903 while (midend > mid) /* shove everything down */
2904 *--bigend = *--midend;
2905 Move(little,big+offset,littlelen,char);
2911 Move(little,SvPVX(bigstr)+offset,len,char);
2916 big = SvPVX(bigstr);
2919 bigend = big + SvCUR(bigstr);
2921 if (midend > bigend)
2922 croak("panic: sv_insert");
2924 if (mid - big > bigend - midend) { /* faster to shorten from end */
2926 Move(little, mid, littlelen,char);
2929 i = bigend - midend;
2931 Move(midend, mid, i,char);
2935 SvCUR_set(bigstr, mid - big);
2938 else if (i = mid - big) { /* faster from front */
2939 midend -= littlelen;
2941 sv_chop(bigstr,midend-i);
2946 Move(little, mid, littlelen,char);
2948 else if (littlelen) {
2949 midend -= littlelen;
2950 sv_chop(bigstr,midend);
2951 Move(little,midend,littlelen,char);
2954 sv_chop(bigstr,midend);
2959 /* make sv point to what nstr did */
2962 sv_replace(register SV *sv, register SV *nsv)
2964 U32 refcnt = SvREFCNT(sv);
2965 SV_CHECK_THINKFIRST(sv);
2966 if (SvREFCNT(nsv) != 1)
2967 warn("Reference miscount in sv_replace()");
2968 if (SvMAGICAL(sv)) {
2972 sv_upgrade(nsv, SVt_PVMG);
2973 SvMAGIC(nsv) = SvMAGIC(sv);
2974 SvFLAGS(nsv) |= SvMAGICAL(sv);
2980 assert(!SvREFCNT(sv));
2981 StructCopy(nsv,sv,SV);
2982 SvREFCNT(sv) = refcnt;
2983 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2988 sv_clear(register SV *sv)
2992 assert(SvREFCNT(sv) == 0);
2996 if (PL_defstash) { /* Still have a symbol table? */
3001 Zero(&tmpref, 1, SV);
3002 sv_upgrade(&tmpref, SVt_RV);
3004 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3005 SvREFCNT(&tmpref) = 1;
3008 stash = SvSTASH(sv);
3009 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3012 PUSHSTACKi(PERLSI_DESTROY);
3013 SvRV(&tmpref) = SvREFCNT_inc(sv);
3018 perl_call_sv((SV*)GvCV(destructor),
3019 G_DISCARD|G_EVAL|G_KEEPERR);
3025 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3027 del_XRV(SvANY(&tmpref));
3030 if (PL_in_clean_objs)
3031 croak("DESTROY created new reference to dead object '%s'",
3033 /* DESTROY gave object new lease on life */
3039 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3040 SvOBJECT_off(sv); /* Curse the object. */
3041 if (SvTYPE(sv) != SVt_PVIO)
3042 --PL_sv_objcount; /* XXX Might want something more general */
3045 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3048 switch (SvTYPE(sv)) {
3051 IoIFP(sv) != PerlIO_stdin() &&
3052 IoIFP(sv) != PerlIO_stdout() &&
3053 IoIFP(sv) != PerlIO_stderr())
3058 PerlDir_close(IoDIRP(sv));
3061 Safefree(IoTOP_NAME(sv));
3062 Safefree(IoFMT_NAME(sv));
3063 Safefree(IoBOTTOM_NAME(sv));
3078 SvREFCNT_dec(LvTARG(sv));
3082 Safefree(GvNAME(sv));
3083 /* cannot decrease stash refcount yet, as we might recursively delete
3084 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3085 of stash until current sv is completely gone.
3086 -- JohnPC, 27 Mar 1998 */
3087 stash = GvSTASH(sv);
3093 (void)SvOOK_off(sv);
3101 SvREFCNT_dec(SvRV(sv));
3103 else if (SvPVX(sv) && SvLEN(sv))
3104 Safefree(SvPVX(sv));
3114 switch (SvTYPE(sv)) {
3130 del_XPVIV(SvANY(sv));
3133 del_XPVNV(SvANY(sv));
3136 del_XPVMG(SvANY(sv));
3139 del_XPVLV(SvANY(sv));
3142 del_XPVAV(SvANY(sv));
3145 del_XPVHV(SvANY(sv));
3148 del_XPVCV(SvANY(sv));
3151 del_XPVGV(SvANY(sv));
3152 /* code duplication for increased performance. */
3153 SvFLAGS(sv) &= SVf_BREAK;
3154 SvFLAGS(sv) |= SVTYPEMASK;
3155 /* decrease refcount of the stash that owns this GV, if any */
3157 SvREFCNT_dec(stash);
3158 return; /* not break, SvFLAGS reset already happened */
3160 del_XPVBM(SvANY(sv));
3163 del_XPVFM(SvANY(sv));
3166 del_XPVIO(SvANY(sv));
3169 SvFLAGS(sv) &= SVf_BREAK;
3170 SvFLAGS(sv) |= SVTYPEMASK;
3177 ATOMIC_INC(SvREFCNT(sv));
3184 int refcount_is_zero;
3188 if (SvREFCNT(sv) == 0) {
3189 if (SvFLAGS(sv) & SVf_BREAK)
3191 if (PL_in_clean_all) /* All is fair */
3193 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3194 /* make sure SvREFCNT(sv)==0 happens very seldom */
3195 SvREFCNT(sv) = (~(U32)0)/2;
3198 warn("Attempt to free unreferenced scalar");
3201 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3202 if (!refcount_is_zero)
3206 warn("Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3210 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3211 /* make sure SvREFCNT(sv)==0 happens very seldom */
3212 SvREFCNT(sv) = (~(U32)0)/2;
3221 sv_len(register SV *sv)
3230 len = mg_length(sv);
3232 junk = SvPV(sv, len);
3237 sv_len_utf8(register SV *sv)
3248 len = mg_length(sv);
3251 s = (U8*)SvPV(sv, len);
3262 sv_pos_u2b(register SV *sv, I32* offsetp, I32* lenp)
3267 I32 uoffset = *offsetp;
3273 start = s = (U8*)SvPV(sv, len);
3275 while (s < send && uoffset--)
3279 *offsetp = s - start;
3283 while (s < send && ulen--)
3293 sv_pos_b2u(register SV *sv, I32* offsetp)
3302 s = (U8*)SvPV(sv, len);
3304 croak("panic: bad byte offset");
3305 send = s + *offsetp;
3312 warn("Malformed UTF-8 character");
3320 sv_eq(register SV *str1, register SV *str2)
3332 pv1 = SvPV(str1, cur1);
3337 pv2 = SvPV(str2, cur2);
3342 return memEQ(pv1, pv2, cur1);
3346 sv_cmp(register SV *str1, register SV *str2)
3349 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3351 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3355 return cur2 ? -1 : 0;
3360 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3363 return retval < 0 ? -1 : 1;
3368 return cur1 < cur2 ? -1 : 1;
3372 sv_cmp_locale(register SV *sv1, register SV *sv2)
3374 #ifdef USE_LOCALE_COLLATE
3380 if (PL_collation_standard)
3384 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3386 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3388 if (!pv1 || !len1) {
3399 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3402 return retval < 0 ? -1 : 1;
3405 * When the result of collation is equality, that doesn't mean
3406 * that there are no differences -- some locales exclude some
3407 * characters from consideration. So to avoid false equalities,
3408 * we use the raw string as a tiebreaker.
3414 #endif /* USE_LOCALE_COLLATE */
3416 return sv_cmp(sv1, sv2);
3419 #ifdef USE_LOCALE_COLLATE
3421 * Any scalar variable may carry an 'o' magic that contains the
3422 * scalar data of the variable transformed to such a format that
3423 * a normal memory comparison can be used to compare the data
3424 * according to the locale settings.
3427 sv_collxfrm(SV *sv, STRLEN *nxp)
3431 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3432 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3437 Safefree(mg->mg_ptr);
3439 if ((xf = mem_collxfrm(s, len, &xlen))) {
3440 if (SvREADONLY(sv)) {
3443 return xf + sizeof(PL_collation_ix);
3446 sv_magic(sv, 0, 'o', 0, 0);
3447 mg = mg_find(sv, 'o');
3460 if (mg && mg->mg_ptr) {
3462 return mg->mg_ptr + sizeof(PL_collation_ix);
3470 #endif /* USE_LOCALE_COLLATE */
3473 sv_gets(register SV *sv, register PerlIO *fp, I32 append)
3478 register STDCHAR rslast;
3479 register STDCHAR *bp;
3483 SV_CHECK_THINKFIRST(sv);
3484 (void)SvUPGRADE(sv, SVt_PV);
3488 if (RsSNARF(PL_rs)) {
3492 else if (RsRECORD(PL_rs)) {
3493 I32 recsize, bytesread;
3496 /* Grab the size of the record we're getting */
3497 recsize = SvIV(SvRV(PL_rs));
3498 (void)SvPOK_only(sv); /* Validate pointer */
3499 buffer = SvGROW(sv, recsize + 1);
3502 /* VMS wants read instead of fread, because fread doesn't respect */
3503 /* RMS record boundaries. This is not necessarily a good thing to be */
3504 /* doing, but we've got no other real choice */
3505 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3507 bytesread = PerlIO_read(fp, buffer, recsize);
3509 SvCUR_set(sv, bytesread);
3510 buffer[bytesread] = '\0';
3511 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3513 else if (RsPARA(PL_rs)) {
3518 rsptr = SvPV(PL_rs, rslen);
3519 rslast = rslen ? rsptr[rslen - 1] : '\0';
3521 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3522 do { /* to make sure file boundaries work right */
3525 i = PerlIO_getc(fp);
3529 PerlIO_ungetc(fp,i);
3535 /* See if we know enough about I/O mechanism to cheat it ! */
3537 /* This used to be #ifdef test - it is made run-time test for ease
3538 of abstracting out stdio interface. One call should be cheap
3539 enough here - and may even be a macro allowing compile
3543 if (PerlIO_fast_gets(fp)) {
3546 * We're going to steal some values from the stdio struct
3547 * and put EVERYTHING in the innermost loop into registers.
3549 register STDCHAR *ptr;
3553 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3554 /* An ungetc()d char is handled separately from the regular
3555 * buffer, so we getc() it back out and stuff it in the buffer.
3557 i = PerlIO_getc(fp);
3558 if (i == EOF) return 0;
3559 *(--((*fp)->_ptr)) = (unsigned char) i;
3563 /* Here is some breathtakingly efficient cheating */
3565 cnt = PerlIO_get_cnt(fp); /* get count into register */
3566 (void)SvPOK_only(sv); /* validate pointer */
3567 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3568 if (cnt > 80 && SvLEN(sv) > append) {
3569 shortbuffered = cnt - SvLEN(sv) + append + 1;
3570 cnt -= shortbuffered;
3574 /* remember that cnt can be negative */
3575 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3580 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3581 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3582 DEBUG_P(PerlIO_printf(Perl_debug_log,
3583 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3584 DEBUG_P(PerlIO_printf(Perl_debug_log,
3585 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3586 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3587 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3592 while (cnt > 0) { /* this | eat */
3594 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3595 goto thats_all_folks; /* screams | sed :-) */
3599 Copy(ptr, bp, cnt, char); /* this | eat */
3600 bp += cnt; /* screams | dust */
3601 ptr += cnt; /* louder | sed :-) */
3606 if (shortbuffered) { /* oh well, must extend */
3607 cnt = shortbuffered;
3609 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3611 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3612 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3616 DEBUG_P(PerlIO_printf(Perl_debug_log,
3617 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3618 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3619 DEBUG_P(PerlIO_printf(Perl_debug_log,
3620 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3621 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3622 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3623 /* This used to call 'filbuf' in stdio form, but as that behaves like
3624 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3625 another abstraction. */
3626 i = PerlIO_getc(fp); /* get more characters */
3627 DEBUG_P(PerlIO_printf(Perl_debug_log,
3628 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3629 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3630 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3631 cnt = PerlIO_get_cnt(fp);
3632 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3633 DEBUG_P(PerlIO_printf(Perl_debug_log,
3634 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3636 if (i == EOF) /* all done for ever? */
3637 goto thats_really_all_folks;
3639 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3641 SvGROW(sv, bpx + cnt + 2);
3642 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3644 *bp++ = i; /* store character from PerlIO_getc */
3646 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3647 goto thats_all_folks;
3651 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3652 memNE((char*)bp - rslen, rsptr, rslen))
3653 goto screamer; /* go back to the fray */
3654 thats_really_all_folks:
3656 cnt += shortbuffered;
3657 DEBUG_P(PerlIO_printf(Perl_debug_log,
3658 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3659 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3660 DEBUG_P(PerlIO_printf(Perl_debug_log,
3661 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3662 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3663 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3665 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3666 DEBUG_P(PerlIO_printf(Perl_debug_log,
3667 "Screamer: done, len=%ld, string=|%.*s|\n",
3668 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3672 /*The big, slow, and stupid way */
3677 register STDCHAR *bpe = buf + sizeof(buf);
3679 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3680 ; /* keep reading */
3684 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3685 /* Accomodate broken VAXC compiler, which applies U8 cast to
3686 * both args of ?: operator, causing EOF to change into 255
3688 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3692 sv_catpvn(sv, (char *) buf, cnt);
3694 sv_setpvn(sv, (char *) buf, cnt);
3696 if (i != EOF && /* joy */
3698 SvCUR(sv) < rslen ||
3699 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3703 * If we're reading from a TTY and we get a short read,
3704 * indicating that the user hit his EOF character, we need
3705 * to notice it now, because if we try to read from the TTY
3706 * again, the EOF condition will disappear.
3708 * The comparison of cnt to sizeof(buf) is an optimization
3709 * that prevents unnecessary calls to feof().
3713 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3718 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3719 while (i != EOF) { /* to make sure file boundaries work right */
3720 i = PerlIO_getc(fp);
3722 PerlIO_ungetc(fp,i);
3729 win32_strip_return(sv);
3732 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3737 sv_inc(register SV *sv)
3746 if (SvTHINKFIRST(sv)) {
3747 if (SvREADONLY(sv)) {
3749 if (PL_curcop != &PL_compiling)
3750 croak(PL_no_modify);
3754 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3761 flags = SvFLAGS(sv);
3762 if (flags & SVp_NOK) {
3763 (void)SvNOK_only(sv);
3767 if (flags & SVp_IOK) {
3769 if (SvUVX(sv) == UV_MAX)
3770 sv_setnv(sv, (double)UV_MAX + 1.0);
3772 (void)SvIOK_only_UV(sv);
3775 if (SvIVX(sv) == IV_MAX)
3776 sv_setnv(sv, (double)IV_MAX + 1.0);
3778 (void)SvIOK_only(sv);
3784 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3785 if ((flags & SVTYPEMASK) < SVt_PVNV)
3786 sv_upgrade(sv, SVt_NV);
3788 (void)SvNOK_only(sv);
3792 while (isALPHA(*d)) d++;
3793 while (isDIGIT(*d)) d++;
3795 SET_NUMERIC_STANDARD();
3796 sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
3800 while (d >= SvPVX(sv)) {
3808 /* MKS: The original code here died if letters weren't consecutive.
3809 * at least it didn't have to worry about non-C locales. The
3810 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3811 * arranged in order (although not consecutively) and that only
3812 * [A-Za-z] are accepted by isALPHA in the C locale.
3814 if (*d != 'z' && *d != 'Z') {
3815 do { ++*d; } while (!isALPHA(*d));
3818 *(d--) -= 'z' - 'a';
3823 *(d--) -= 'z' - 'a' + 1;
3827 /* oh,oh, the number grew */
3828 SvGROW(sv, SvCUR(sv) + 2);
3830 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3839 sv_dec(register SV *sv)
3847 if (SvTHINKFIRST(sv)) {
3848 if (SvREADONLY(sv)) {
3850 if (PL_curcop != &PL_compiling)
3851 croak(PL_no_modify);
3855 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3862 flags = SvFLAGS(sv);
3863 if (flags & SVp_NOK) {
3865 (void)SvNOK_only(sv);
3868 if (flags & SVp_IOK) {
3870 if (SvUVX(sv) == 0) {
3871 (void)SvIOK_only(sv);
3875 (void)SvIOK_only_UV(sv);
3879 if (SvIVX(sv) == IV_MIN)
3880 sv_setnv(sv, (double)IV_MIN - 1.0);
3882 (void)SvIOK_only(sv);
3888 if (!(flags & SVp_POK)) {
3889 if ((flags & SVTYPEMASK) < SVt_PVNV)
3890 sv_upgrade(sv, SVt_NV);
3892 (void)SvNOK_only(sv);
3895 SET_NUMERIC_STANDARD();
3896 sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
3899 /* Make a string that will exist for the duration of the expression
3900 * evaluation. Actually, it may have to last longer than that, but
3901 * hopefully we won't free it until it has been assigned to a
3902 * permanent location. */
3905 sv_mortalcopy(SV *oldstr)
3911 sv_setsv(sv,oldstr);
3913 PL_tmps_stack[++PL_tmps_ix] = sv;
3925 SvFLAGS(sv) = SVs_TEMP;
3927 PL_tmps_stack[++PL_tmps_ix] = sv;
3931 /* same thing without the copying */
3934 sv_2mortal(register SV *sv)
3939 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3942 PL_tmps_stack[++PL_tmps_ix] = sv;
3948 newSVpv(const char *s, STRLEN len)
3955 sv_setpvn(sv,s,len);
3960 newSVpvn(const char *s, STRLEN len)
3965 sv_setpvn(sv,s,len);
3970 newSVpvf(const char* pat, ...)
3976 va_start(args, pat);
3977 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4004 newRV_noinc(SV *tmpRef)
4010 sv_upgrade(sv, SVt_RV);
4020 return newRV_noinc(SvREFCNT_inc(tmpRef));
4023 /* make an exact duplicate of old */
4026 newSVsv(register SV *old)
4032 if (SvTYPE(old) == SVTYPEMASK) {
4033 warn("semi-panic: attempt to dup freed string");
4048 sv_reset(register char *s, HV *stash)
4061 if (!*s) { /* reset ?? searches */
4062 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4063 pm->op_pmdynflags &= ~PMdf_USED;
4068 /* reset variables */
4070 if (!HvARRAY(stash))
4073 Zero(todo, 256, char);
4080 for ( ; i <= max; i++) {
4083 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4084 for (entry = HvARRAY(stash)[i];
4086 entry = HeNEXT(entry))
4088 if (!todo[(U8)*HeKEY(entry)])
4090 gv = (GV*)HeVAL(entry);
4092 if (SvTHINKFIRST(sv)) {
4093 if (!SvREADONLY(sv) && SvROK(sv))
4098 if (SvTYPE(sv) >= SVt_PV) {
4100 if (SvPVX(sv) != Nullch)
4107 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4109 #ifndef VMS /* VMS has no environ array */
4111 environ[0] = Nullch;
4126 switch (SvTYPE(sv)) {
4134 croak("Bad filehandle: %s", GvNAME(gv));
4138 croak(PL_no_usym, "filehandle");
4140 return sv_2io(SvRV(sv));
4141 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4147 croak("Bad filehandle: %s", SvPV(sv,n_a));
4154 sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref)
4161 return *gvp = Nullgv, Nullcv;
4162 switch (SvTYPE(sv)) {
4182 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4183 tryAMAGICunDEREF(to_cv);
4186 if (SvTYPE(sv) == SVt_PVCV) {
4195 croak("Not a subroutine reference");
4200 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4206 if (lref && !GvCVu(gv)) {
4209 tmpsv = NEWSV(704,0);
4210 gv_efullname3(tmpsv, gv, Nullch);
4211 /* XXX this is probably not what they think they're getting.
4212 * It has the same effect as "sub name;", i.e. just a forward
4214 newSUB(start_subparse(FALSE, 0),
4215 newSVOP(OP_CONST, 0, tmpsv),
4220 croak("Unable to create sub named \"%s\"", SvPV(sv,n_a));
4227 sv_true(register SV *sv)
4234 if ((tXpv = (XPV*)SvANY(sv)) &&
4235 (*tXpv->xpv_pv > '0' ||
4236 tXpv->xpv_cur > 1 ||
4237 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4244 return SvIVX(sv) != 0;
4247 return SvNVX(sv) != 0.0;
4249 return sv_2bool(sv);
4255 sv_iv(register SV *sv)
4259 return (IV)SvUVX(sv);
4266 sv_uv(register SV *sv)
4271 return (UV)SvIVX(sv);
4277 sv_nv(register SV *sv)
4292 return sv_2pv(sv, &n_a);
4296 sv_pvn(SV *sv, STRLEN *lp)
4302 return sv_2pv(sv, lp);
4306 sv_pvn_force(SV *sv, STRLEN *lp)
4310 if (SvTHINKFIRST(sv) && !SvROK(sv))
4311 sv_force_normal(sv);
4317 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4319 croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
4320 PL_op_name[PL_op->op_type]);
4324 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4329 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4330 SvGROW(sv, len + 1);
4331 Move(s,SvPVX(sv),len,char);
4336 SvPOK_on(sv); /* validate pointer */
4338 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4339 (unsigned long)sv,SvPVX(sv)));
4346 sv_reftype(SV *sv, int ob)
4348 if (ob && SvOBJECT(sv))
4349 return HvNAME(SvSTASH(sv));
4351 switch (SvTYPE(sv)) {
4365 case SVt_PVLV: return "LVALUE";
4366 case SVt_PVAV: return "ARRAY";
4367 case SVt_PVHV: return "HASH";
4368 case SVt_PVCV: return "CODE";
4369 case SVt_PVGV: return "GLOB";
4370 case SVt_PVFM: return "FORMAT";
4371 default: return "UNKNOWN";
4392 sv_isa(SV *sv, const char *name)
4404 return strEQ(HvNAME(SvSTASH(sv)), name);
4408 newSVrv(SV *rv, const char *classname)
4415 SV_CHECK_THINKFIRST(rv);
4418 if (SvTYPE(rv) < SVt_RV)
4419 sv_upgrade(rv, SVt_RV);
4426 HV* stash = gv_stashpv(classname, TRUE);
4427 (void)sv_bless(rv, stash);
4433 sv_setref_pv(SV *rv, const char *classname, void *pv)
4436 sv_setsv(rv, &PL_sv_undef);
4440 sv_setiv(newSVrv(rv,classname), (IV)pv);
4445 sv_setref_iv(SV *rv, const char *classname, IV iv)
4447 sv_setiv(newSVrv(rv,classname), iv);
4452 sv_setref_nv(SV *rv, const char *classname, double nv)
4454 sv_setnv(newSVrv(rv,classname), nv);
4459 sv_setref_pvn(SV *rv, const char *classname, char *pv, STRLEN n)
4461 sv_setpvn(newSVrv(rv,classname), pv, n);
4466 sv_bless(SV *sv, HV *stash)
4471 croak("Can't bless non-reference value");
4473 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4474 if (SvREADONLY(tmpRef))
4475 croak(PL_no_modify);
4476 if (SvOBJECT(tmpRef)) {
4477 if (SvTYPE(tmpRef) != SVt_PVIO)
4479 SvREFCNT_dec(SvSTASH(tmpRef));
4482 SvOBJECT_on(tmpRef);
4483 if (SvTYPE(tmpRef) != SVt_PVIO)
4485 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4486 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4499 assert(SvTYPE(sv) == SVt_PVGV);
4504 SvREFCNT_dec(GvSTASH(sv));
4505 GvSTASH(sv) = Nullhv;
4507 sv_unmagic(sv, '*');
4508 Safefree(GvNAME(sv));
4510 SvFLAGS(sv) &= ~SVTYPEMASK;
4511 SvFLAGS(sv) |= SVt_PVMG;
4519 if (SvWEAKREF(sv)) {
4527 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4530 sv_2mortal(rv); /* Schedule for freeing later */
4536 sv_magic((sv), Nullsv, 't', Nullch, 0);
4542 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4543 MAGIC *mg = mg_find(sv, 't');
4552 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4553 MAGIC *mg = mg_find(sv, 't');
4554 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4561 sv_setpviv(SV *sv, IV iv)
4563 char buf[TYPE_CHARS(UV)];
4565 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4567 sv_setpvn(sv, ptr, ebuf - ptr);
4572 sv_setpviv_mg(SV *sv, IV iv)
4574 char buf[TYPE_CHARS(UV)];
4576 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4578 sv_setpvn(sv, ptr, ebuf - ptr);
4583 sv_setpvf(SV *sv, const char* pat, ...)
4586 va_start(args, pat);
4587 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4593 sv_setpvf_mg(SV *sv, const char* pat, ...)
4596 va_start(args, pat);
4597 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4603 sv_catpvf(SV *sv, const char* pat, ...)
4606 va_start(args, pat);
4607 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4612 sv_catpvf_mg(SV *sv, const char* pat, ...)
4615 va_start(args, pat);
4616 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4622 sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4624 sv_setpvn(sv, "", 0);
4625 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4629 sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4637 static char nullstr[] = "(null)";
4639 /* no matter what, this is a string now */
4640 (void)SvPV_force(sv, origlen);
4642 /* special-case "", "%s", and "%_" */
4645 if (patlen == 2 && pat[0] == '%') {
4649 char *s = va_arg(*args, char*);
4650 sv_catpv(sv, s ? s : nullstr);
4652 else if (svix < svmax)
4653 sv_catsv(sv, *svargs);
4657 sv_catsv(sv, va_arg(*args, SV*));
4660 /* See comment on '_' below */
4665 patend = (char*)pat + patlen;
4666 for (p = (char*)pat; p < patend; p = q) {
4674 bool has_precis = FALSE;
4679 STRLEN esignlen = 0;
4681 char *eptr = Nullch;
4683 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4694 for (q = p; q < patend && *q != '%'; ++q) ;
4696 sv_catpvn(sv, p, q - p);
4734 case '1': case '2': case '3':
4735 case '4': case '5': case '6':
4736 case '7': case '8': case '9':
4739 width = width * 10 + (*q++ - '0');
4744 i = va_arg(*args, int);
4746 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4748 width = (i < 0) ? -i : i;
4759 i = va_arg(*args, int);
4761 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4762 precis = (i < 0) ? 0 : i;
4768 precis = precis * 10 + (*q++ - '0');
4777 #if 0 /* when quads have better support within Perl */
4778 if (*(q + 1) == 'l') {
4805 uv = va_arg(*args, int);
4807 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4809 eptr = (char*)utf8buf;
4810 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4814 c = va_arg(*args, int);
4816 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4823 eptr = va_arg(*args, char*);
4825 elen = strlen(eptr);
4828 elen = sizeof nullstr - 1;
4831 else if (svix < svmax) {
4832 eptr = SvPVx(svargs[svix++], elen);
4834 if (has_precis && precis < elen) {
4836 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4839 if (width) { /* fudge width (can't fudge elen) */
4840 width += elen - sv_len_utf8(svargs[svix - 1]);
4848 * The "%_" hack might have to be changed someday,
4849 * if ISO or ANSI decide to use '_' for something.
4850 * So we keep it hidden from users' code.
4854 eptr = SvPVx(va_arg(*args, SV*), elen);
4857 if (has_precis && elen > precis)
4865 uv = (UV)va_arg(*args, void*);
4867 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4878 case 'h': iv = (short)va_arg(*args, int); break;
4879 default: iv = va_arg(*args, int); break;
4880 case 'l': iv = va_arg(*args, long); break;
4881 case 'V': iv = va_arg(*args, IV); break;
4885 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4887 case 'h': iv = (short)iv; break;
4888 default: iv = (int)iv; break;
4889 case 'l': iv = (long)iv; break;
4896 esignbuf[esignlen++] = plus;
4900 esignbuf[esignlen++] = '-';
4930 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4931 default: uv = va_arg(*args, unsigned); break;
4932 case 'l': uv = va_arg(*args, unsigned long); break;
4933 case 'V': uv = va_arg(*args, UV); break;
4937 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4939 case 'h': uv = (unsigned short)uv; break;
4940 default: uv = (unsigned)uv; break;
4941 case 'l': uv = (unsigned long)uv; break;
4947 eptr = ebuf + sizeof ebuf;
4953 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
4959 esignbuf[esignlen++] = '0';
4960 esignbuf[esignlen++] = c; /* 'x' or 'X' */
4966 *--eptr = '0' + dig;
4968 if (alt && *eptr != '0')
4974 *--eptr = '0' + dig;
4976 if (alt && *eptr != '0')
4979 default: /* it had better be ten or less */
4982 *--eptr = '0' + dig;
4983 } while (uv /= base);
4986 elen = (ebuf + sizeof ebuf) - eptr;
4989 zeros = precis - elen;
4990 else if (precis == 0 && elen == 1 && *eptr == '0')
4995 /* FLOATING POINT */
4998 c = 'f'; /* maybe %F isn't supported here */
5004 /* This is evil, but floating point is even more evil */
5007 nv = va_arg(*args, double);
5009 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5012 if (c != 'e' && c != 'E') {
5014 (void)frexp(nv, &i);
5015 if (i == PERL_INT_MIN)
5016 die("panic: frexp");
5018 need = BIT_DIGITS(i);
5020 need += has_precis ? precis : 6; /* known default */
5024 need += 20; /* fudge factor */
5025 if (PL_efloatsize < need) {
5026 Safefree(PL_efloatbuf);
5027 PL_efloatsize = need + 20; /* more fudge */
5028 New(906, PL_efloatbuf, PL_efloatsize, char);
5031 eptr = ebuf + sizeof ebuf;
5036 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5041 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5053 (void)sprintf(PL_efloatbuf, eptr, nv);
5055 eptr = PL_efloatbuf;
5056 elen = strlen(PL_efloatbuf);
5060 * User-defined locales may include arbitrary characters.
5061 * And, unfortunately, some system may alloc the "C" locale
5062 * to be overridden by a malicious user.
5065 *used_locale = TRUE;
5066 #endif /* LC_NUMERIC */
5073 i = SvCUR(sv) - origlen;
5076 case 'h': *(va_arg(*args, short*)) = i; break;
5077 default: *(va_arg(*args, int*)) = i; break;
5078 case 'l': *(va_arg(*args, long*)) = i; break;
5079 case 'V': *(va_arg(*args, IV*)) = i; break;
5082 else if (svix < svmax)
5083 sv_setuv(svargs[svix++], (UV)i);
5084 continue; /* not "break" */
5090 if (!args && ckWARN(WARN_PRINTF) &&
5091 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5092 SV *msg = sv_newmortal();
5093 sv_setpvf(msg, "Invalid conversion in %s: ",
5094 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5096 sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5099 sv_catpv(msg, "end of string");
5100 warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5103 /* output mangled stuff ... */
5109 /* ... right here, because formatting flags should not apply */
5110 SvGROW(sv, SvCUR(sv) + elen + 1);
5112 memcpy(p, eptr, elen);
5115 SvCUR(sv) = p - SvPVX(sv);
5116 continue; /* not "break" */
5119 have = esignlen + zeros + elen;
5120 need = (have > width ? have : width);
5123 SvGROW(sv, SvCUR(sv) + need + 1);
5125 if (esignlen && fill == '0') {
5126 for (i = 0; i < esignlen; i++)
5130 memset(p, fill, gap);
5133 if (esignlen && fill != '0') {
5134 for (i = 0; i < esignlen; i++)
5138 for (i = zeros; i; i--)
5142 memcpy(p, eptr, elen);
5146 memset(p, ' ', gap);
5150 SvCUR(sv) = p - SvPVX(sv);