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)
123 if (PL_sv_count >= (registry_size >> 1))
125 SV **oldreg = registry;
126 I32 oldsize = registry_size;
128 registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
129 Newz(707, registry, registry_size, SV*);
134 for (i = 0; i < oldsize; ++i) {
135 SV* oldsv = oldreg[i];
161 for (i = 0; i < registry_size; ++i) {
162 SV* sv = registry[i];
163 if (sv && SvTYPE(sv) != SVTYPEMASK)
169 sv_add_arena(ptr, size, flags)
174 if (!(flags & SVf_FAKE))
181 * "A time to plant, and a time to uproot what was planted..."
184 #define plant_SV(p) \
186 SvANY(p) = (void *)PL_sv_root; \
187 SvFLAGS(p) = SVTYPEMASK; \
192 /* sv_mutex must be held while calling uproot_SV() */
193 #define uproot_SV(p) \
196 PL_sv_root = (SV*)SvANY(p); \
218 if (PL_debug & 32768) \
228 if (PL_debug & 32768) {
233 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
235 svend = &sva[SvREFCNT(sva)];
236 if (p >= sv && p < svend)
240 warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
247 #else /* ! DEBUGGING */
249 #define del_SV(p) plant_SV(p)
251 #endif /* DEBUGGING */
254 sv_add_arena(char *ptr, U32 size, U32 flags)
259 Zero(sva, size, char);
261 /* The first SV in an arena isn't an SV. */
262 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
263 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
264 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
266 PL_sv_arenaroot = sva;
267 PL_sv_root = sva + 1;
269 svend = &sva[SvREFCNT(sva) - 1];
272 SvANY(sv) = (void *)(SV*)(sv + 1);
273 SvFLAGS(sv) = SVTYPEMASK;
277 SvFLAGS(sv) = SVTYPEMASK;
280 /* sv_mutex must be held while calling more_sv() */
287 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
288 PL_nice_chunk = Nullch;
291 char *chunk; /* must use New here to match call to */
292 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
293 sv_add_arena(chunk, 1008, 0);
306 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
307 svend = &sva[SvREFCNT(sva)];
308 for (sv = sva + 1; sv < svend; ++sv) {
309 if (SvTYPE(sv) != SVTYPEMASK)
318 do_report_used(SV *sv)
320 if (SvTYPE(sv) != SVTYPEMASK) {
321 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
322 PerlIO_printf(PerlIO_stderr(), "****\n");
330 visit(FUNC_NAME_TO_PTR(do_report_used));
334 do_clean_objs(SV *sv)
338 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
339 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
345 /* XXX Might want to check arrays, etc. */
348 #ifndef DISABLE_DESTRUCTOR_KLUDGE
350 do_clean_named_objs(SV *sv)
352 if (SvTYPE(sv) == SVt_PVGV) {
353 if ( SvOBJECT(GvSV(sv)) ||
354 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
355 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
356 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
357 GvCV(sv) && SvOBJECT(GvCV(sv)) )
359 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
369 PL_in_clean_objs = TRUE;
370 visit(FUNC_NAME_TO_PTR(do_clean_objs));
371 #ifndef DISABLE_DESTRUCTOR_KLUDGE
372 /* some barnacles may yet remain, clinging to typeglobs */
373 visit(FUNC_NAME_TO_PTR(do_clean_named_objs));
375 PL_in_clean_objs = FALSE;
381 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
382 SvFLAGS(sv) |= SVf_BREAK;
389 PL_in_clean_all = TRUE;
390 visit(FUNC_NAME_TO_PTR(do_clean_all));
391 PL_in_clean_all = FALSE;
400 /* Free arenas here, but be careful about fake ones. (We assume
401 contiguity of the fake ones with the corresponding real ones.) */
403 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
404 svanext = (SV*) SvANY(sva);
405 while (svanext && SvFAKE(svanext))
406 svanext = (SV*) SvANY(svanext);
409 Safefree((void *)sva);
413 Safefree(PL_nice_chunk);
414 PL_nice_chunk = Nullch;
415 PL_nice_chunk_size = 0;
429 * See comment in more_xiv() -- RAM.
431 PL_xiv_root = *(IV**)xiv;
433 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
439 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
441 *(IV**)xiv = PL_xiv_root;
452 New(705, ptr, 1008/sizeof(XPV), XPV);
453 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
454 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
457 xivend = &xiv[1008 / sizeof(IV) - 1];
458 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
460 while (xiv < xivend) {
461 *(IV**)xiv = (IV *)(xiv + 1);
475 PL_xnv_root = *(double**)xnv;
477 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
483 double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
485 *(double**)xnv = PL_xnv_root;
493 register double* xnv;
494 register double* xnvend;
495 New(711, xnv, 1008/sizeof(double), double);
496 xnvend = &xnv[1008 / sizeof(double) - 1];
497 xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */
499 while (xnv < xnvend) {
500 *(double**)xnv = (double*)(xnv + 1);
514 PL_xrv_root = (XRV*)xrv->xrv_rv;
523 p->xrv_rv = (SV*)PL_xrv_root;
532 register XRV* xrvend;
533 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
535 xrvend = &xrv[1008 / sizeof(XRV) - 1];
536 while (xrv < xrvend) {
537 xrv->xrv_rv = (SV*)(xrv + 1);
551 PL_xpv_root = (XPV*)xpv->xpv_pv;
560 p->xpv_pv = (char*)PL_xpv_root;
569 register XPV* xpvend;
570 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
572 xpvend = &xpv[1008 / sizeof(XPV) - 1];
573 while (xpv < xpvend) {
574 xpv->xpv_pv = (char*)(xpv + 1);
581 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
582 #define del_XIV(p) Safefree((char*)p)
584 #define new_XIV() (void*)new_xiv()
585 #define del_XIV(p) del_xiv((XPVIV*) p)
589 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
590 #define del_XNV(p) Safefree((char*)p)
592 #define new_XNV() (void*)new_xnv()
593 #define del_XNV(p) del_xnv((XPVNV*) p)
597 #define new_XRV() (void*)safemalloc(sizeof(XRV))
598 #define del_XRV(p) Safefree((char*)p)
600 #define new_XRV() (void*)new_xrv()
601 #define del_XRV(p) del_xrv((XRV*) p)
605 #define new_XPV() (void*)safemalloc(sizeof(XPV))
606 #define del_XPV(p) Safefree((char*)p)
608 #define new_XPV() (void*)new_xpv()
609 #define del_XPV(p) del_xpv((XPV *)p)
613 # define my_safemalloc(s) safemalloc(s)
614 # define my_safefree(s) safefree(s)
617 my_safemalloc(MEM_SIZE size)
620 New(717, p, size, char);
623 # define my_safefree(s) Safefree(s)
626 #define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
627 #define del_XPVIV(p) my_safefree((char*)p)
629 #define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
630 #define del_XPVNV(p) my_safefree((char*)p)
632 #define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
633 #define del_XPVMG(p) my_safefree((char*)p)
635 #define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
636 #define del_XPVLV(p) my_safefree((char*)p)
638 #define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
639 #define del_XPVAV(p) my_safefree((char*)p)
641 #define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
642 #define del_XPVHV(p) my_safefree((char*)p)
644 #define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
645 #define del_XPVCV(p) my_safefree((char*)p)
647 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
648 #define del_XPVGV(p) my_safefree((char*)p)
650 #define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
651 #define del_XPVBM(p) my_safefree((char*)p)
653 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
654 #define del_XPVFM(p) my_safefree((char*)p)
656 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
657 #define del_XPVIO(p) my_safefree((char*)p)
660 sv_upgrade(register SV *sv, U32 mt)
670 if (SvTYPE(sv) == mt)
676 switch (SvTYPE(sv)) {
691 nv = (double)SvIVX(sv);
697 else if (mt < SVt_PVIV)
714 pv = (char*)SvRV(sv);
718 nv = (double)(unsigned long)pv;
734 else if (mt == SVt_NV)
745 del_XPVIV(SvANY(sv));
755 del_XPVNV(SvANY(sv));
765 del_XPVMG(SvANY(sv));
768 croak("Can't upgrade that kind of scalar");
773 croak("Can't upgrade to undef");
775 SvANY(sv) = new_XIV();
779 SvANY(sv) = new_XNV();
783 SvANY(sv) = new_XRV();
787 SvANY(sv) = new_XPV();
793 SvANY(sv) = new_XPVIV();
803 SvANY(sv) = new_XPVNV();
811 SvANY(sv) = new_XPVMG();
821 SvANY(sv) = new_XPVLV();
835 SvANY(sv) = new_XPVAV();
850 SvANY(sv) = new_XPVHV();
866 SvANY(sv) = new_XPVCV();
867 Zero(SvANY(sv), 1, XPVCV);
877 SvANY(sv) = new_XPVGV();
892 SvANY(sv) = new_XPVBM();
905 SvANY(sv) = new_XPVFM();
906 Zero(SvANY(sv), 1, XPVFM);
916 SvANY(sv) = new_XPVIO();
917 Zero(SvANY(sv), 1, XPVIO);
928 SvFLAGS(sv) &= ~SVTYPEMASK;
934 sv_backoff(register SV *sv)
939 SvLEN(sv) += SvIVX(sv);
940 SvPVX(sv) -= SvIVX(sv);
942 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
944 SvFLAGS(sv) &= ~SVf_OOK;
949 sv_grow(register SV *sv, register STRLEN newlen)
954 if (newlen >= 0x10000) {
955 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
958 #endif /* HAS_64K_LIMIT */
961 if (SvTYPE(sv) < SVt_PV) {
962 sv_upgrade(sv, SVt_PV);
965 else if (SvOOK(sv)) { /* pv is offset? */
968 if (newlen > SvLEN(sv))
969 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
971 if (newlen >= 0x10000)
977 if (newlen > SvLEN(sv)) { /* need more room? */
978 if (SvLEN(sv) && s) {
979 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
980 STRLEN l = malloced_size((void*)SvPVX(sv));
986 Renew(s,newlen,char);
989 New(703,s,newlen,char);
991 SvLEN_set(sv, newlen);
997 sv_setiv(register SV *sv, IV i)
999 SV_CHECK_THINKFIRST(sv);
1000 switch (SvTYPE(sv)) {
1002 sv_upgrade(sv, SVt_IV);
1005 sv_upgrade(sv, SVt_PVNV);
1009 sv_upgrade(sv, SVt_PVIV);
1020 croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
1021 PL_op_desc[PL_op->op_type]);
1024 (void)SvIOK_only(sv); /* validate number */
1030 sv_setiv_mg(register SV *sv, IV i)
1037 sv_setuv(register SV *sv, UV u)
1045 sv_setuv_mg(register SV *sv, UV u)
1052 sv_setnv(register SV *sv, double num)
1054 SV_CHECK_THINKFIRST(sv);
1055 switch (SvTYPE(sv)) {
1058 sv_upgrade(sv, SVt_NV);
1063 sv_upgrade(sv, SVt_PVNV);
1074 croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
1075 PL_op_name[PL_op->op_type]);
1079 (void)SvNOK_only(sv); /* validate number */
1084 sv_setnv_mg(register SV *sv, double num)
1091 not_a_number(SV *sv)
1097 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1098 /* each *s can expand to 4 chars + "...\0",
1099 i.e. need room for 8 chars */
1101 for (s = SvPVX(sv); *s && d < limit; s++) {
1103 if (ch & 128 && !isPRINT_LC(ch)) {
1112 else if (ch == '\r') {
1116 else if (ch == '\f') {
1120 else if (ch == '\\') {
1124 else if (isPRINT_LC(ch))
1139 warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
1140 PL_op_name[PL_op->op_type]);
1142 warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
1145 /* the number can be converted to _integer_ with atol() */
1146 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1147 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1148 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1149 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1151 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1152 until proven guilty, assume that things are not that bad... */
1155 sv_2iv(register SV *sv)
1159 if (SvGMAGICAL(sv)) {
1164 return I_V(SvNVX(sv));
1166 if (SvPOKp(sv) && SvLEN(sv))
1169 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1171 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1172 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1177 if (SvTHINKFIRST(sv)) {
1180 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1181 return SvIV(tmpstr);
1182 return (IV)SvRV(sv);
1184 if (SvREADONLY(sv)) {
1186 return I_V(SvNVX(sv));
1188 if (SvPOKp(sv) && SvLEN(sv))
1192 if (ckWARN(WARN_UNINITIALIZED))
1193 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1200 return (IV)(SvUVX(sv));
1207 /* We can cache the IV/UV value even if it not good enough
1208 * to reconstruct NV, since the conversion to PV will prefer
1209 * NV over IV/UV. XXXX 64-bit?
1212 if (SvTYPE(sv) == SVt_NV)
1213 sv_upgrade(sv, SVt_PVNV);
1216 if (SvNVX(sv) < (double)IV_MAX + 0.5)
1217 SvIVX(sv) = I_V(SvNVX(sv));
1219 SvUVX(sv) = U_V(SvNVX(sv));
1222 DEBUG_c(PerlIO_printf(Perl_debug_log,
1223 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1225 (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
1226 return (IV)SvUVX(sv);
1229 else if (SvPOKp(sv) && SvLEN(sv)) {
1230 I32 numtype = looks_like_number(sv);
1232 /* We want to avoid a possible problem when we cache an IV which
1233 may be later translated to an NV, and the resulting NV is not
1234 the translation of the initial data.
1236 This means that if we cache such an IV, we need to cache the
1237 NV as well. Moreover, we trade speed for space, and do not
1238 cache the NV if not needed.
1240 if (numtype & IS_NUMBER_NOT_IV) {
1241 /* May be not an integer. Need to cache NV if we cache IV
1242 * - otherwise future conversion to NV will be wrong. */
1245 SET_NUMERIC_STANDARD();
1246 d = atof(SvPVX(sv));
1248 if (SvTYPE(sv) < SVt_PVNV)
1249 sv_upgrade(sv, SVt_PVNV);
1253 DEBUG_c(PerlIO_printf(Perl_debug_log,
1254 "0x%lx 2nv(%g)\n",(unsigned long)sv,
1256 if (SvNVX(sv) < (double)IV_MAX + 0.5)
1257 SvIVX(sv) = I_V(SvNVX(sv));
1259 SvUVX(sv) = U_V(SvNVX(sv));
1265 /* The NV may be reconstructed from IV - safe to cache IV,
1266 which may be calculated by atol(). */
1267 if (SvTYPE(sv) == SVt_PV)
1268 sv_upgrade(sv, SVt_PVIV);
1270 SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
1272 else { /* Not a number. Cache 0. */
1275 if (SvTYPE(sv) < SVt_PVIV)
1276 sv_upgrade(sv, SVt_PVIV);
1279 if (ckWARN(WARN_NUMERIC))
1285 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1286 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1287 if (SvTYPE(sv) < SVt_IV)
1288 /* Typically the caller expects that sv_any is not NULL now. */
1289 sv_upgrade(sv, SVt_IV);
1292 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1293 (unsigned long)sv,(long)SvIVX(sv)));
1294 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1298 sv_2uv(register SV *sv)
1302 if (SvGMAGICAL(sv)) {
1307 return U_V(SvNVX(sv));
1308 if (SvPOKp(sv) && SvLEN(sv))
1311 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1313 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1314 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1319 if (SvTHINKFIRST(sv)) {
1322 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1323 return SvUV(tmpstr);
1324 return (UV)SvRV(sv);
1326 if (SvREADONLY(sv)) {
1328 return U_V(SvNVX(sv));
1330 if (SvPOKp(sv) && SvLEN(sv))
1334 if (ckWARN(WARN_UNINITIALIZED))
1335 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1345 return (UV)SvIVX(sv);
1349 /* We can cache the IV/UV value even if it not good enough
1350 * to reconstruct NV, since the conversion to PV will prefer
1351 * NV over IV/UV. XXXX 64-bit?
1353 if (SvTYPE(sv) == SVt_NV)
1354 sv_upgrade(sv, SVt_PVNV);
1356 if (SvNVX(sv) >= -0.5) {
1358 SvUVX(sv) = U_V(SvNVX(sv));
1361 SvIVX(sv) = I_V(SvNVX(sv));
1363 DEBUG_c(PerlIO_printf(Perl_debug_log,
1364 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1365 (unsigned long)sv,(long)SvIVX(sv),
1366 (long)(UV)SvIVX(sv)));
1367 return (UV)SvIVX(sv);
1370 else if (SvPOKp(sv) && SvLEN(sv)) {
1371 I32 numtype = looks_like_number(sv);
1373 /* We want to avoid a possible problem when we cache a UV which
1374 may be later translated to an NV, and the resulting NV is not
1375 the translation of the initial data.
1377 This means that if we cache such a UV, we need to cache the
1378 NV as well. Moreover, we trade speed for space, and do not
1379 cache the NV if not needed.
1381 if (numtype & IS_NUMBER_NOT_IV) {
1382 /* May be not an integer. Need to cache NV if we cache IV
1383 * - otherwise future conversion to NV will be wrong. */
1386 SET_NUMERIC_STANDARD();
1387 d = atof(SvPVX(sv)); /* XXXX 64-bit? */
1389 if (SvTYPE(sv) < SVt_PVNV)
1390 sv_upgrade(sv, SVt_PVNV);
1394 DEBUG_c(PerlIO_printf(Perl_debug_log,
1395 "0x%lx 2nv(%g)\n",(unsigned long)sv,
1397 if (SvNVX(sv) < -0.5) {
1398 SvIVX(sv) = I_V(SvNVX(sv));
1401 SvUVX(sv) = U_V(SvNVX(sv));
1405 else if (numtype & IS_NUMBER_NEG) {
1406 /* The NV may be reconstructed from IV - safe to cache IV,
1407 which may be calculated by atol(). */
1408 if (SvTYPE(sv) == SVt_PV)
1409 sv_upgrade(sv, SVt_PVIV);
1411 SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1413 else if (numtype) { /* Non-negative */
1414 /* The NV may be reconstructed from UV - safe to cache UV,
1415 which may be calculated by strtoul()/atol. */
1416 if (SvTYPE(sv) == SVt_PV)
1417 sv_upgrade(sv, SVt_PVIV);
1419 (void)SvIsUV_on(sv);
1421 SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
1422 #else /* no atou(), but we know the number fits into IV... */
1423 /* The only problem may be if it is negative... */
1424 SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1427 else { /* Not a number. Cache 0. */
1430 if (SvTYPE(sv) < SVt_PVIV)
1431 sv_upgrade(sv, SVt_PVIV);
1432 SvUVX(sv) = 0; /* We assume that 0s have the
1433 same bitmap in IV and UV. */
1435 (void)SvIsUV_on(sv);
1436 if (ckWARN(WARN_NUMERIC))
1441 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1443 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1444 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1446 if (SvTYPE(sv) < SVt_IV)
1447 /* Typically the caller expects that sv_any is not NULL now. */
1448 sv_upgrade(sv, SVt_IV);
1452 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1453 (unsigned long)sv,SvUVX(sv)));
1454 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1458 sv_2nv(register SV *sv)
1462 if (SvGMAGICAL(sv)) {
1466 if (SvPOKp(sv) && SvLEN(sv)) {
1468 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1470 SET_NUMERIC_STANDARD();
1471 return atof(SvPVX(sv));
1475 return (double)SvUVX(sv);
1477 return (double)SvIVX(sv);
1480 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1482 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1483 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1488 if (SvTHINKFIRST(sv)) {
1491 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1492 return SvNV(tmpstr);
1493 return (double)(unsigned long)SvRV(sv);
1495 if (SvREADONLY(sv)) {
1497 if (SvPOKp(sv) && SvLEN(sv)) {
1498 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1500 SET_NUMERIC_STANDARD();
1501 return atof(SvPVX(sv));
1505 return (double)SvUVX(sv);
1507 return (double)SvIVX(sv);
1509 if (ckWARN(WARN_UNINITIALIZED))
1510 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1514 if (SvTYPE(sv) < SVt_NV) {
1515 if (SvTYPE(sv) == SVt_IV)
1516 sv_upgrade(sv, SVt_PVNV);
1518 sv_upgrade(sv, SVt_NV);
1519 DEBUG_c(SET_NUMERIC_STANDARD());
1520 DEBUG_c(PerlIO_printf(Perl_debug_log,
1521 "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
1523 else if (SvTYPE(sv) < SVt_PVNV)
1524 sv_upgrade(sv, SVt_PVNV);
1526 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1528 SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv);
1530 else if (SvPOKp(sv) && SvLEN(sv)) {
1532 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1534 SET_NUMERIC_STANDARD();
1535 SvNVX(sv) = atof(SvPVX(sv));
1539 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1540 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1541 if (SvTYPE(sv) < SVt_NV)
1542 /* Typically the caller expects that sv_any is not NULL now. */
1543 sv_upgrade(sv, SVt_NV);
1547 DEBUG_c(SET_NUMERIC_STANDARD());
1548 DEBUG_c(PerlIO_printf(Perl_debug_log,
1549 "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
1556 I32 numtype = looks_like_number(sv);
1559 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1560 return atol(SvPVX(sv)); /* XXXX 64-bit? */
1563 if (ckWARN(WARN_NUMERIC))
1566 SET_NUMERIC_STANDARD();
1567 d = atof(SvPVX(sv));
1574 I32 numtype = looks_like_number(sv);
1577 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1578 return strtoul(SvPVX(sv), Null(char**), 10);
1582 if (ckWARN(WARN_NUMERIC))
1585 SET_NUMERIC_STANDARD();
1586 return U_V(atof(SvPVX(sv)));
1590 * Returns a combination of (advisory only - can get false negatives)
1591 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1593 * 0 if does not look like number.
1595 * In fact possible values are 0 and
1596 * IS_NUMBER_TO_INT_BY_ATOL 123
1597 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1598 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1599 * with a possible addition of IS_NUMBER_NEG.
1603 looks_like_number(SV *sv)
1605 /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
1606 * using atof() may lose precision. */
1608 register char *send;
1609 register char *sbegin;
1610 register char *nbegin;
1618 else if (SvPOKp(sv))
1619 sbegin = SvPV(sv, len);
1622 send = sbegin + len;
1629 numtype = IS_NUMBER_NEG;
1636 * we return 1 if the number can be converted to _integer_ with atol()
1637 * and 2 if you need (int)atof().
1640 /* next must be digit or '.' */
1644 } while (isDIGIT(*s));
1646 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1647 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1649 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1653 numtype |= IS_NUMBER_NOT_IV;
1654 while (isDIGIT(*s)) /* optional digits after "." */
1658 else if (*s == '.') {
1660 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1661 /* no digits before '.' means we need digits after it */
1665 } while (isDIGIT(*s));
1673 /* we can have an optional exponent part */
1674 if (*s == 'e' || *s == 'E') {
1675 numtype &= ~IS_NUMBER_NEG;
1676 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1678 if (*s == '+' || *s == '-')
1683 } while (isDIGIT(*s));
1692 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1693 return IS_NUMBER_TO_INT_BY_ATOL;
1698 sv_2pv_nolen(register SV *sv)
1701 return sv_2pv(sv, &n_a);
1704 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1706 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1709 char *ptr = buf + TYPE_CHARS(UV);
1724 *--ptr = '0' + (uv % 10);
1733 sv_2pv(register SV *sv, STRLEN *lp)
1738 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1739 char *tmpbuf = tbuf;
1745 if (SvGMAGICAL(sv)) {
1751 if (SvIOKp(sv)) { /* XXXX 64-bit? */
1753 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1755 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1760 SET_NUMERIC_STANDARD();
1761 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1766 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1768 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1769 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1775 if (SvTHINKFIRST(sv)) {
1778 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1779 return SvPV(tmpstr,*lp);
1786 switch (SvTYPE(sv)) {
1788 if ( ((SvFLAGS(sv) &
1789 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1790 == (SVs_OBJECT|SVs_RMG))
1791 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1792 && (mg = mg_find(sv, 'r'))) {
1794 regexp *re = (regexp *)mg->mg_obj;
1797 char *fptr = "msix";
1802 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1804 while(ch = *fptr++) {
1806 reflags[left++] = ch;
1809 reflags[right--] = ch;
1814 reflags[left] = '-';
1818 mg->mg_len = re->prelen + 4 + left;
1819 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1820 Copy("(?", mg->mg_ptr, 2, char);
1821 Copy(reflags, mg->mg_ptr+2, left, char);
1822 Copy(":", mg->mg_ptr+left+2, 1, char);
1823 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1824 mg->mg_ptr[mg->mg_len - 1] = ')';
1825 mg->mg_ptr[mg->mg_len] = 0;
1827 PL_reginterp_cnt += re->program[0].next_off;
1839 case SVt_PVBM: s = "SCALAR"; break;
1840 case SVt_PVLV: s = "LVALUE"; break;
1841 case SVt_PVAV: s = "ARRAY"; break;
1842 case SVt_PVHV: s = "HASH"; break;
1843 case SVt_PVCV: s = "CODE"; break;
1844 case SVt_PVGV: s = "GLOB"; break;
1845 case SVt_PVFM: s = "FORMAT"; break;
1846 case SVt_PVIO: s = "IO"; break;
1847 default: s = "UNKNOWN"; break;
1851 sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1855 sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
1861 if (SvREADONLY(sv)) {
1862 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1863 /* XXXX 64-bit? IV may have better precision... */
1864 SET_NUMERIC_STANDARD();
1865 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1873 tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
1875 tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
1882 if (ckWARN(WARN_UNINITIALIZED))
1883 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1889 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1890 /* XXXX 64-bit? IV may have better precision... */
1891 if (SvTYPE(sv) < SVt_PVNV)
1892 sv_upgrade(sv, SVt_PVNV);
1895 olderrno = errno; /* some Xenix systems wipe out errno here */
1897 if (SvNVX(sv) == 0.0)
1898 (void)strcpy(s,"0");
1902 SET_NUMERIC_STANDARD();
1903 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1906 #ifdef FIXNEGATIVEZERO
1907 if (*s == '-' && s[1] == '0' && !s[2])
1916 else if (SvIOKp(sv)) {
1917 U32 isIOK = SvIOK(sv);
1918 char buf[TYPE_CHARS(UV)];
1921 if (SvTYPE(sv) < SVt_PVIV)
1922 sv_upgrade(sv, SVt_PVIV);
1924 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1925 sv_setpvn(sv, ptr, ebuf - ptr);
1929 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1930 sv_setpvn(sv, ptr, ebuf - ptr);
1940 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1941 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1943 if (SvTYPE(sv) < SVt_PV)
1944 /* Typically the caller expects that sv_any is not NULL now. */
1945 sv_upgrade(sv, SVt_PV);
1948 *lp = s - SvPVX(sv);
1951 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1955 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1956 /* Sneaky stuff here */
1960 tsv = newSVpv(tmpbuf, 0);
1976 len = strlen(tmpbuf);
1978 #ifdef FIXNEGATIVEZERO
1979 if (len == 2 && t[0] == '-' && t[1] == '0') {
1984 (void)SvUPGRADE(sv, SVt_PV);
1986 s = SvGROW(sv, len + 1);
1994 /* This function is only called on magical items */
1996 sv_2bool(register SV *sv)
2006 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2007 return SvTRUE(tmpsv);
2008 return SvRV(sv) != 0;
2011 register XPV* Xpvtmp;
2012 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2013 (*Xpvtmp->xpv_pv > '0' ||
2014 Xpvtmp->xpv_cur > 1 ||
2015 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2022 return SvIVX(sv) != 0;
2025 return SvNVX(sv) != 0.0;
2032 /* Note: sv_setsv() should not be called with a source string that needs
2033 * to be reused, since it may destroy the source string if it is marked
2038 sv_setsv(SV *dstr, register SV *sstr)
2041 register U32 sflags;
2047 SV_CHECK_THINKFIRST(dstr);
2049 sstr = &PL_sv_undef;
2050 stype = SvTYPE(sstr);
2051 dtype = SvTYPE(dstr);
2055 /* There's a lot of redundancy below but we're going for speed here */
2060 if (dtype != SVt_PVGV) {
2061 (void)SvOK_off(dstr);
2069 sv_upgrade(dstr, SVt_IV);
2072 sv_upgrade(dstr, SVt_PVNV);
2076 sv_upgrade(dstr, SVt_PVIV);
2079 (void)SvIOK_only(dstr);
2080 SvIVX(dstr) = SvIVX(sstr);
2093 sv_upgrade(dstr, SVt_NV);
2098 sv_upgrade(dstr, SVt_PVNV);
2101 SvNVX(dstr) = SvNVX(sstr);
2102 (void)SvNOK_only(dstr);
2110 sv_upgrade(dstr, SVt_RV);
2111 else if (dtype == SVt_PVGV &&
2112 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2115 if (PL_curcop->cop_stash != GvSTASH(dstr))
2116 GvIMPORTED_on(dstr);
2126 sv_upgrade(dstr, SVt_PV);
2129 if (dtype < SVt_PVIV)
2130 sv_upgrade(dstr, SVt_PVIV);
2133 if (dtype < SVt_PVNV)
2134 sv_upgrade(dstr, SVt_PVNV);
2141 croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2142 PL_op_name[PL_op->op_type]);
2144 croak("Bizarre copy of %s", sv_reftype(sstr, 0));
2148 if (dtype <= SVt_PVGV) {
2150 if (dtype != SVt_PVGV) {
2151 char *name = GvNAME(sstr);
2152 STRLEN len = GvNAMELEN(sstr);
2153 sv_upgrade(dstr, SVt_PVGV);
2154 sv_magic(dstr, dstr, '*', name, len);
2155 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2156 GvNAME(dstr) = savepvn(name, len);
2157 GvNAMELEN(dstr) = len;
2158 SvFAKE_on(dstr); /* can coerce to non-glob */
2160 /* ahem, death to those who redefine active sort subs */
2161 else if (PL_curstackinfo->si_type == PERLSI_SORT
2162 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2163 croak("Can't redefine active sort subroutine %s",
2165 (void)SvOK_off(dstr);
2166 GvINTRO_off(dstr); /* one-shot flag */
2168 GvGP(dstr) = gp_ref(GvGP(sstr));
2170 if (PL_curcop->cop_stash != GvSTASH(dstr))
2171 GvIMPORTED_on(dstr);
2178 if (SvGMAGICAL(sstr)) {
2180 if (SvTYPE(sstr) != stype) {
2181 stype = SvTYPE(sstr);
2182 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2186 if (stype == SVt_PVLV)
2187 (void)SvUPGRADE(dstr, SVt_PVNV);
2189 (void)SvUPGRADE(dstr, stype);
2192 sflags = SvFLAGS(sstr);
2194 if (sflags & SVf_ROK) {
2195 if (dtype >= SVt_PV) {
2196 if (dtype == SVt_PVGV) {
2197 SV *sref = SvREFCNT_inc(SvRV(sstr));
2199 int intro = GvINTRO(dstr);
2203 GvGP(dstr)->gp_refcnt--;
2204 GvINTRO_off(dstr); /* one-shot flag */
2205 Newz(602,gp, 1, GP);
2206 GvGP(dstr) = gp_ref(gp);
2207 GvSV(dstr) = NEWSV(72,0);
2208 GvLINE(dstr) = PL_curcop->cop_line;
2209 GvEGV(dstr) = (GV*)dstr;
2212 switch (SvTYPE(sref)) {
2215 SAVESPTR(GvAV(dstr));
2217 dref = (SV*)GvAV(dstr);
2218 GvAV(dstr) = (AV*)sref;
2219 if (PL_curcop->cop_stash != GvSTASH(dstr))
2220 GvIMPORTED_AV_on(dstr);
2224 SAVESPTR(GvHV(dstr));
2226 dref = (SV*)GvHV(dstr);
2227 GvHV(dstr) = (HV*)sref;
2228 if (PL_curcop->cop_stash != GvSTASH(dstr))
2229 GvIMPORTED_HV_on(dstr);
2233 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2234 SvREFCNT_dec(GvCV(dstr));
2235 GvCV(dstr) = Nullcv;
2236 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2237 PL_sub_generation++;
2239 SAVESPTR(GvCV(dstr));
2242 dref = (SV*)GvCV(dstr);
2243 if (GvCV(dstr) != (CV*)sref) {
2244 CV* cv = GvCV(dstr);
2246 if (!GvCVGEN((GV*)dstr) &&
2247 (CvROOT(cv) || CvXSUB(cv)))
2249 SV *const_sv = cv_const_sv(cv);
2250 bool const_changed = TRUE;
2252 const_changed = sv_cmp(const_sv,
2253 op_const_sv(CvSTART((CV*)sref),
2255 /* ahem, death to those who redefine
2256 * active sort subs */
2257 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2258 PL_sortcop == CvSTART(cv))
2260 "Can't redefine active sort subroutine %s",
2261 GvENAME((GV*)dstr));
2262 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2263 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2264 && HvNAME(GvSTASH(CvGV(cv)))
2265 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2267 warner(WARN_REDEFINE, const_sv ?
2268 "Constant subroutine %s redefined"
2269 : "Subroutine %s redefined",
2270 GvENAME((GV*)dstr));
2273 cv_ckproto(cv, (GV*)dstr,
2274 SvPOK(sref) ? SvPVX(sref) : Nullch);
2276 GvCV(dstr) = (CV*)sref;
2277 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2278 GvASSUMECV_on(dstr);
2279 PL_sub_generation++;
2281 if (PL_curcop->cop_stash != GvSTASH(dstr))
2282 GvIMPORTED_CV_on(dstr);
2286 SAVESPTR(GvIOp(dstr));
2288 dref = (SV*)GvIOp(dstr);
2289 GvIOp(dstr) = (IO*)sref;
2293 SAVESPTR(GvSV(dstr));
2295 dref = (SV*)GvSV(dstr);
2297 if (PL_curcop->cop_stash != GvSTASH(dstr))
2298 GvIMPORTED_SV_on(dstr);
2309 (void)SvOOK_off(dstr); /* backoff */
2311 Safefree(SvPVX(dstr));
2312 SvLEN(dstr)=SvCUR(dstr)=0;
2315 (void)SvOK_off(dstr);
2316 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2318 if (sflags & SVp_NOK) {
2320 SvNVX(dstr) = SvNVX(sstr);
2322 if (sflags & SVp_IOK) {
2323 (void)SvIOK_on(dstr);
2324 SvIVX(dstr) = SvIVX(sstr);
2328 if (SvAMAGIC(sstr)) {
2332 else if (sflags & SVp_POK) {
2335 * Check to see if we can just swipe the string. If so, it's a
2336 * possible small lose on short strings, but a big win on long ones.
2337 * It might even be a win on short strings if SvPVX(dstr)
2338 * has to be allocated and SvPVX(sstr) has to be freed.
2341 if (SvTEMP(sstr) && /* slated for free anyway? */
2342 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2343 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2345 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2347 SvFLAGS(dstr) &= ~SVf_OOK;
2348 Safefree(SvPVX(dstr) - SvIVX(dstr));
2350 else if (SvLEN(dstr))
2351 Safefree(SvPVX(dstr));
2353 (void)SvPOK_only(dstr);
2354 SvPV_set(dstr, SvPVX(sstr));
2355 SvLEN_set(dstr, SvLEN(sstr));
2356 SvCUR_set(dstr, SvCUR(sstr));
2358 (void)SvOK_off(sstr);
2359 SvPV_set(sstr, Nullch);
2364 else { /* have to copy actual string */
2365 STRLEN len = SvCUR(sstr);
2367 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2368 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2369 SvCUR_set(dstr, len);
2370 *SvEND(dstr) = '\0';
2371 (void)SvPOK_only(dstr);
2374 if (sflags & SVp_NOK) {
2376 SvNVX(dstr) = SvNVX(sstr);
2378 if (sflags & SVp_IOK) {
2379 (void)SvIOK_on(dstr);
2380 SvIVX(dstr) = SvIVX(sstr);
2385 else if (sflags & SVp_NOK) {
2386 SvNVX(dstr) = SvNVX(sstr);
2387 (void)SvNOK_only(dstr);
2389 (void)SvIOK_on(dstr);
2390 SvIVX(dstr) = SvIVX(sstr);
2391 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2396 else if (sflags & SVp_IOK) {
2397 (void)SvIOK_only(dstr);
2398 SvIVX(dstr) = SvIVX(sstr);
2403 if (dtype == SVt_PVGV) {
2404 if (ckWARN(WARN_UNSAFE))
2405 warner(WARN_UNSAFE, "Undefined value assigned to typeglob");
2408 (void)SvOK_off(dstr);
2414 sv_setsv_mg(SV *dstr, register SV *sstr)
2416 sv_setsv(dstr,sstr);
2421 sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len)
2423 register char *dptr;
2424 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2425 elicit a warning, but it won't hurt. */
2426 SV_CHECK_THINKFIRST(sv);
2431 (void)SvUPGRADE(sv, SVt_PV);
2433 SvGROW(sv, len + 1);
2435 Move(ptr,dptr,len,char);
2438 (void)SvPOK_only(sv); /* validate pointer */
2443 sv_setpvn_mg(register SV *sv, register const char *ptr, register STRLEN len)
2445 sv_setpvn(sv,ptr,len);
2450 sv_setpv(register SV *sv, register const char *ptr)
2452 register STRLEN len;
2454 SV_CHECK_THINKFIRST(sv);
2460 (void)SvUPGRADE(sv, SVt_PV);
2462 SvGROW(sv, len + 1);
2463 Move(ptr,SvPVX(sv),len+1,char);
2465 (void)SvPOK_only(sv); /* validate pointer */
2470 sv_setpv_mg(register SV *sv, register const char *ptr)
2477 sv_usepvn(register SV *sv, register char *ptr, register STRLEN len)
2479 SV_CHECK_THINKFIRST(sv);
2480 (void)SvUPGRADE(sv, SVt_PV);
2485 (void)SvOOK_off(sv);
2486 if (SvPVX(sv) && SvLEN(sv))
2487 Safefree(SvPVX(sv));
2488 Renew(ptr, len+1, char);
2491 SvLEN_set(sv, len+1);
2493 (void)SvPOK_only(sv); /* validate pointer */
2498 sv_usepvn_mg(register SV *sv, register char *ptr, register STRLEN len)
2500 sv_usepvn(sv,ptr,len);
2505 sv_force_normal(register SV *sv)
2507 if (SvREADONLY(sv)) {
2509 if (PL_curcop != &PL_compiling)
2510 croak(PL_no_modify);
2514 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2519 sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2523 register STRLEN delta;
2525 if (!ptr || !SvPOKp(sv))
2527 SV_CHECK_THINKFIRST(sv);
2528 if (SvTYPE(sv) < SVt_PVIV)
2529 sv_upgrade(sv,SVt_PVIV);
2532 if (!SvLEN(sv)) { /* make copy of shared string */
2533 char *pvx = SvPVX(sv);
2534 STRLEN len = SvCUR(sv);
2535 SvGROW(sv, len + 1);
2536 Move(pvx,SvPVX(sv),len,char);
2540 SvFLAGS(sv) |= SVf_OOK;
2542 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2543 delta = ptr - SvPVX(sv);
2551 sv_catpvn(register SV *sv, register const char *ptr, register STRLEN len)
2556 junk = SvPV_force(sv, tlen);
2557 SvGROW(sv, tlen + len + 1);
2560 Move(ptr,SvPVX(sv)+tlen,len,char);
2563 (void)SvPOK_only(sv); /* validate pointer */
2568 sv_catpvn_mg(register SV *sv, register const char *ptr, register STRLEN len)
2570 sv_catpvn(sv,ptr,len);
2575 sv_catsv(SV *dstr, register SV *sstr)
2581 if (s = SvPV(sstr, len))
2582 sv_catpvn(dstr,s,len);
2586 sv_catsv_mg(SV *dstr, register SV *sstr)
2588 sv_catsv(dstr,sstr);
2593 sv_catpv(register SV *sv, register const char *ptr)
2595 register STRLEN len;
2601 junk = SvPV_force(sv, tlen);
2603 SvGROW(sv, tlen + len + 1);
2606 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2608 (void)SvPOK_only(sv); /* validate pointer */
2613 sv_catpv_mg(register SV *sv, register const char *ptr)
2626 sv_upgrade(sv, SVt_PV);
2627 SvGROW(sv, len + 1);
2632 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2635 sv_magic(register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2639 if (SvREADONLY(sv)) {
2641 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2642 croak(PL_no_modify);
2644 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2645 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2652 (void)SvUPGRADE(sv, SVt_PVMG);
2654 Newz(702,mg, 1, MAGIC);
2655 mg->mg_moremagic = SvMAGIC(sv);
2658 if (!obj || obj == sv || how == '#' || how == 'r')
2662 mg->mg_obj = SvREFCNT_inc(obj);
2663 mg->mg_flags |= MGf_REFCOUNTED;
2666 mg->mg_len = namlen;
2669 mg->mg_ptr = savepvn(name, namlen);
2670 else if (namlen == HEf_SVKEY)
2671 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2675 mg->mg_virtual = &PL_vtbl_sv;
2678 mg->mg_virtual = &PL_vtbl_amagic;
2681 mg->mg_virtual = &PL_vtbl_amagicelem;
2687 mg->mg_virtual = &PL_vtbl_bm;
2690 mg->mg_virtual = &PL_vtbl_regdata;
2693 mg->mg_virtual = &PL_vtbl_regdatum;
2696 mg->mg_virtual = &PL_vtbl_env;
2699 mg->mg_virtual = &PL_vtbl_fm;
2702 mg->mg_virtual = &PL_vtbl_envelem;
2705 mg->mg_virtual = &PL_vtbl_mglob;
2708 mg->mg_virtual = &PL_vtbl_isa;
2711 mg->mg_virtual = &PL_vtbl_isaelem;
2714 mg->mg_virtual = &PL_vtbl_nkeys;
2721 mg->mg_virtual = &PL_vtbl_dbline;
2725 mg->mg_virtual = &PL_vtbl_mutex;
2727 #endif /* USE_THREADS */
2728 #ifdef USE_LOCALE_COLLATE
2730 mg->mg_virtual = &PL_vtbl_collxfrm;
2732 #endif /* USE_LOCALE_COLLATE */
2734 mg->mg_virtual = &PL_vtbl_pack;
2738 mg->mg_virtual = &PL_vtbl_packelem;
2741 mg->mg_virtual = &PL_vtbl_regexp;
2744 mg->mg_virtual = &PL_vtbl_sig;
2747 mg->mg_virtual = &PL_vtbl_sigelem;
2750 mg->mg_virtual = &PL_vtbl_taint;
2754 mg->mg_virtual = &PL_vtbl_uvar;
2757 mg->mg_virtual = &PL_vtbl_vec;
2760 mg->mg_virtual = &PL_vtbl_substr;
2763 mg->mg_virtual = &PL_vtbl_defelem;
2766 mg->mg_virtual = &PL_vtbl_glob;
2769 mg->mg_virtual = &PL_vtbl_arylen;
2772 mg->mg_virtual = &PL_vtbl_pos;
2775 mg->mg_virtual = &PL_vtbl_backref;
2777 case '~': /* Reserved for use by extensions not perl internals. */
2778 /* Useful for attaching extension internal data to perl vars. */
2779 /* Note that multiple extensions may clash if magical scalars */
2780 /* etc holding private data from one are passed to another. */
2784 croak("Don't know how to handle magic of type '%c'", how);
2788 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2792 sv_unmagic(SV *sv, int type)
2796 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2799 for (mg = *mgp; mg; mg = *mgp) {
2800 if (mg->mg_type == type) {
2801 MGVTBL* vtbl = mg->mg_virtual;
2802 *mgp = mg->mg_moremagic;
2803 if (vtbl && (vtbl->svt_free != NULL))
2804 (VTBL->svt_free)(sv, mg);
2805 if (mg->mg_ptr && mg->mg_type != 'g')
2806 if (mg->mg_len >= 0)
2807 Safefree(mg->mg_ptr);
2808 else if (mg->mg_len == HEf_SVKEY)
2809 SvREFCNT_dec((SV*)mg->mg_ptr);
2810 if (mg->mg_flags & MGf_REFCOUNTED)
2811 SvREFCNT_dec(mg->mg_obj);
2815 mgp = &mg->mg_moremagic;
2819 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2829 if (!SvOK(sv)) /* let undefs pass */
2832 croak("Can't weaken a nonreference");
2833 else if (SvWEAKREF(sv)) {
2835 if (ckWARN(WARN_MISC))
2836 warner(WARN_MISC, "Reference is already weak");
2840 sv_add_backref(tsv, sv);
2847 sv_add_backref(SV *tsv, SV *sv)
2851 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2852 av = (AV*)mg->mg_obj;
2855 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2856 SvREFCNT_dec(av); /* for sv_magic */
2862 sv_del_backref(SV *sv)
2869 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2870 croak("panic: del_backref");
2871 av = (AV *)mg->mg_obj;
2876 svp[i] = &PL_sv_undef; /* XXX */
2883 sv_insert(SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2887 register char *midend;
2888 register char *bigend;
2894 croak("Can't modify non-existent substring");
2895 SvPV_force(bigstr, curlen);
2896 if (offset + len > curlen) {
2897 SvGROW(bigstr, offset+len+1);
2898 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2899 SvCUR_set(bigstr, offset+len);
2902 i = littlelen - len;
2903 if (i > 0) { /* string might grow */
2904 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2905 mid = big + offset + len;
2906 midend = bigend = big + SvCUR(bigstr);
2909 while (midend > mid) /* shove everything down */
2910 *--bigend = *--midend;
2911 Move(little,big+offset,littlelen,char);
2917 Move(little,SvPVX(bigstr)+offset,len,char);
2922 big = SvPVX(bigstr);
2925 bigend = big + SvCUR(bigstr);
2927 if (midend > bigend)
2928 croak("panic: sv_insert");
2930 if (mid - big > bigend - midend) { /* faster to shorten from end */
2932 Move(little, mid, littlelen,char);
2935 i = bigend - midend;
2937 Move(midend, mid, i,char);
2941 SvCUR_set(bigstr, mid - big);
2944 else if (i = mid - big) { /* faster from front */
2945 midend -= littlelen;
2947 sv_chop(bigstr,midend-i);
2952 Move(little, mid, littlelen,char);
2954 else if (littlelen) {
2955 midend -= littlelen;
2956 sv_chop(bigstr,midend);
2957 Move(little,midend,littlelen,char);
2960 sv_chop(bigstr,midend);
2965 /* make sv point to what nstr did */
2968 sv_replace(register SV *sv, register SV *nsv)
2970 U32 refcnt = SvREFCNT(sv);
2971 SV_CHECK_THINKFIRST(sv);
2972 if (SvREFCNT(nsv) != 1)
2973 warn("Reference miscount in sv_replace()");
2974 if (SvMAGICAL(sv)) {
2978 sv_upgrade(nsv, SVt_PVMG);
2979 SvMAGIC(nsv) = SvMAGIC(sv);
2980 SvFLAGS(nsv) |= SvMAGICAL(sv);
2986 assert(!SvREFCNT(sv));
2987 StructCopy(nsv,sv,SV);
2988 SvREFCNT(sv) = refcnt;
2989 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2994 sv_clear(register SV *sv)
2998 assert(SvREFCNT(sv) == 0);
3002 if (PL_defstash) { /* Still have a symbol table? */
3007 Zero(&tmpref, 1, SV);
3008 sv_upgrade(&tmpref, SVt_RV);
3010 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3011 SvREFCNT(&tmpref) = 1;
3014 stash = SvSTASH(sv);
3015 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3018 PUSHSTACKi(PERLSI_DESTROY);
3019 SvRV(&tmpref) = SvREFCNT_inc(sv);
3024 perl_call_sv((SV*)GvCV(destructor),
3025 G_DISCARD|G_EVAL|G_KEEPERR);
3031 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3033 del_XRV(SvANY(&tmpref));
3036 if (PL_in_clean_objs)
3037 croak("DESTROY created new reference to dead object '%s'",
3039 /* DESTROY gave object new lease on life */
3045 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3046 SvOBJECT_off(sv); /* Curse the object. */
3047 if (SvTYPE(sv) != SVt_PVIO)
3048 --PL_sv_objcount; /* XXX Might want something more general */
3051 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3054 switch (SvTYPE(sv)) {
3057 IoIFP(sv) != PerlIO_stdin() &&
3058 IoIFP(sv) != PerlIO_stdout() &&
3059 IoIFP(sv) != PerlIO_stderr())
3064 PerlDir_close(IoDIRP(sv));
3067 Safefree(IoTOP_NAME(sv));
3068 Safefree(IoFMT_NAME(sv));
3069 Safefree(IoBOTTOM_NAME(sv));
3084 SvREFCNT_dec(LvTARG(sv));
3088 Safefree(GvNAME(sv));
3089 /* cannot decrease stash refcount yet, as we might recursively delete
3090 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3091 of stash until current sv is completely gone.
3092 -- JohnPC, 27 Mar 1998 */
3093 stash = GvSTASH(sv);
3099 (void)SvOOK_off(sv);
3107 SvREFCNT_dec(SvRV(sv));
3109 else if (SvPVX(sv) && SvLEN(sv))
3110 Safefree(SvPVX(sv));
3120 switch (SvTYPE(sv)) {
3136 del_XPVIV(SvANY(sv));
3139 del_XPVNV(SvANY(sv));
3142 del_XPVMG(SvANY(sv));
3145 del_XPVLV(SvANY(sv));
3148 del_XPVAV(SvANY(sv));
3151 del_XPVHV(SvANY(sv));
3154 del_XPVCV(SvANY(sv));
3157 del_XPVGV(SvANY(sv));
3158 /* code duplication for increased performance. */
3159 SvFLAGS(sv) &= SVf_BREAK;
3160 SvFLAGS(sv) |= SVTYPEMASK;
3161 /* decrease refcount of the stash that owns this GV, if any */
3163 SvREFCNT_dec(stash);
3164 return; /* not break, SvFLAGS reset already happened */
3166 del_XPVBM(SvANY(sv));
3169 del_XPVFM(SvANY(sv));
3172 del_XPVIO(SvANY(sv));
3175 SvFLAGS(sv) &= SVf_BREAK;
3176 SvFLAGS(sv) |= SVTYPEMASK;
3183 ATOMIC_INC(SvREFCNT(sv));
3190 int refcount_is_zero;
3194 if (SvREFCNT(sv) == 0) {
3195 if (SvFLAGS(sv) & SVf_BREAK)
3197 if (PL_in_clean_all) /* All is fair */
3199 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3200 /* make sure SvREFCNT(sv)==0 happens very seldom */
3201 SvREFCNT(sv) = (~(U32)0)/2;
3204 warn("Attempt to free unreferenced scalar");
3207 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3208 if (!refcount_is_zero)
3212 warn("Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3216 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3217 /* make sure SvREFCNT(sv)==0 happens very seldom */
3218 SvREFCNT(sv) = (~(U32)0)/2;
3227 sv_len(register SV *sv)
3236 len = mg_length(sv);
3238 junk = SvPV(sv, len);
3243 sv_len_utf8(register SV *sv)
3254 len = mg_length(sv);
3257 s = (U8*)SvPV(sv, len);
3268 sv_pos_u2b(register SV *sv, I32* offsetp, I32* lenp)
3273 I32 uoffset = *offsetp;
3279 start = s = (U8*)SvPV(sv, len);
3281 while (s < send && uoffset--)
3285 *offsetp = s - start;
3289 while (s < send && ulen--)
3299 sv_pos_b2u(register SV *sv, I32* offsetp)
3308 s = (U8*)SvPV(sv, len);
3310 croak("panic: bad byte offset");
3311 send = s + *offsetp;
3318 warn("Malformed UTF-8 character");
3326 sv_eq(register SV *str1, register SV *str2)
3338 pv1 = SvPV(str1, cur1);
3343 pv2 = SvPV(str2, cur2);
3348 return memEQ(pv1, pv2, cur1);
3352 sv_cmp(register SV *str1, register SV *str2)
3355 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3357 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3361 return cur2 ? -1 : 0;
3366 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3369 return retval < 0 ? -1 : 1;
3374 return cur1 < cur2 ? -1 : 1;
3378 sv_cmp_locale(register SV *sv1, register SV *sv2)
3380 #ifdef USE_LOCALE_COLLATE
3386 if (PL_collation_standard)
3390 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3392 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3394 if (!pv1 || !len1) {
3405 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3408 return retval < 0 ? -1 : 1;
3411 * When the result of collation is equality, that doesn't mean
3412 * that there are no differences -- some locales exclude some
3413 * characters from consideration. So to avoid false equalities,
3414 * we use the raw string as a tiebreaker.
3420 #endif /* USE_LOCALE_COLLATE */
3422 return sv_cmp(sv1, sv2);
3425 #ifdef USE_LOCALE_COLLATE
3427 * Any scalar variable may carry an 'o' magic that contains the
3428 * scalar data of the variable transformed to such a format that
3429 * a normal memory comparison can be used to compare the data
3430 * according to the locale settings.
3433 sv_collxfrm(SV *sv, STRLEN *nxp)
3437 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3438 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3443 Safefree(mg->mg_ptr);
3445 if ((xf = mem_collxfrm(s, len, &xlen))) {
3446 if (SvREADONLY(sv)) {
3449 return xf + sizeof(PL_collation_ix);
3452 sv_magic(sv, 0, 'o', 0, 0);
3453 mg = mg_find(sv, 'o');
3466 if (mg && mg->mg_ptr) {
3468 return mg->mg_ptr + sizeof(PL_collation_ix);
3476 #endif /* USE_LOCALE_COLLATE */
3479 sv_gets(register SV *sv, register PerlIO *fp, I32 append)
3484 register STDCHAR rslast;
3485 register STDCHAR *bp;
3489 SV_CHECK_THINKFIRST(sv);
3490 (void)SvUPGRADE(sv, SVt_PV);
3494 if (RsSNARF(PL_rs)) {
3498 else if (RsRECORD(PL_rs)) {
3499 I32 recsize, bytesread;
3502 /* Grab the size of the record we're getting */
3503 recsize = SvIV(SvRV(PL_rs));
3504 (void)SvPOK_only(sv); /* Validate pointer */
3505 buffer = SvGROW(sv, recsize + 1);
3508 /* VMS wants read instead of fread, because fread doesn't respect */
3509 /* RMS record boundaries. This is not necessarily a good thing to be */
3510 /* doing, but we've got no other real choice */
3511 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3513 bytesread = PerlIO_read(fp, buffer, recsize);
3515 SvCUR_set(sv, bytesread);
3516 buffer[bytesread] = '\0';
3517 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3519 else if (RsPARA(PL_rs)) {
3524 rsptr = SvPV(PL_rs, rslen);
3525 rslast = rslen ? rsptr[rslen - 1] : '\0';
3527 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3528 do { /* to make sure file boundaries work right */
3531 i = PerlIO_getc(fp);
3535 PerlIO_ungetc(fp,i);
3541 /* See if we know enough about I/O mechanism to cheat it ! */
3543 /* This used to be #ifdef test - it is made run-time test for ease
3544 of abstracting out stdio interface. One call should be cheap
3545 enough here - and may even be a macro allowing compile
3549 if (PerlIO_fast_gets(fp)) {
3552 * We're going to steal some values from the stdio struct
3553 * and put EVERYTHING in the innermost loop into registers.
3555 register STDCHAR *ptr;
3559 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3560 /* An ungetc()d char is handled separately from the regular
3561 * buffer, so we getc() it back out and stuff it in the buffer.
3563 i = PerlIO_getc(fp);
3564 if (i == EOF) return 0;
3565 *(--((*fp)->_ptr)) = (unsigned char) i;
3569 /* Here is some breathtakingly efficient cheating */
3571 cnt = PerlIO_get_cnt(fp); /* get count into register */
3572 (void)SvPOK_only(sv); /* validate pointer */
3573 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3574 if (cnt > 80 && SvLEN(sv) > append) {
3575 shortbuffered = cnt - SvLEN(sv) + append + 1;
3576 cnt -= shortbuffered;
3580 /* remember that cnt can be negative */
3581 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3586 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3587 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3588 DEBUG_P(PerlIO_printf(Perl_debug_log,
3589 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3590 DEBUG_P(PerlIO_printf(Perl_debug_log,
3591 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3592 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3593 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3598 while (cnt > 0) { /* this | eat */
3600 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3601 goto thats_all_folks; /* screams | sed :-) */
3605 Copy(ptr, bp, cnt, char); /* this | eat */
3606 bp += cnt; /* screams | dust */
3607 ptr += cnt; /* louder | sed :-) */
3612 if (shortbuffered) { /* oh well, must extend */
3613 cnt = shortbuffered;
3615 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3617 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3618 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3622 DEBUG_P(PerlIO_printf(Perl_debug_log,
3623 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3624 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3625 DEBUG_P(PerlIO_printf(Perl_debug_log,
3626 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3627 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3628 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3629 /* This used to call 'filbuf' in stdio form, but as that behaves like
3630 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3631 another abstraction. */
3632 i = PerlIO_getc(fp); /* get more characters */
3633 DEBUG_P(PerlIO_printf(Perl_debug_log,
3634 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3635 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3636 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3637 cnt = PerlIO_get_cnt(fp);
3638 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3639 DEBUG_P(PerlIO_printf(Perl_debug_log,
3640 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3642 if (i == EOF) /* all done for ever? */
3643 goto thats_really_all_folks;
3645 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3647 SvGROW(sv, bpx + cnt + 2);
3648 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3650 *bp++ = i; /* store character from PerlIO_getc */
3652 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3653 goto thats_all_folks;
3657 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3658 memNE((char*)bp - rslen, rsptr, rslen))
3659 goto screamer; /* go back to the fray */
3660 thats_really_all_folks:
3662 cnt += shortbuffered;
3663 DEBUG_P(PerlIO_printf(Perl_debug_log,
3664 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3665 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3666 DEBUG_P(PerlIO_printf(Perl_debug_log,
3667 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3668 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3669 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3671 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3672 DEBUG_P(PerlIO_printf(Perl_debug_log,
3673 "Screamer: done, len=%ld, string=|%.*s|\n",
3674 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3678 /*The big, slow, and stupid way */
3683 register STDCHAR *bpe = buf + sizeof(buf);
3685 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3686 ; /* keep reading */
3690 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3691 /* Accomodate broken VAXC compiler, which applies U8 cast to
3692 * both args of ?: operator, causing EOF to change into 255
3694 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3698 sv_catpvn(sv, (char *) buf, cnt);
3700 sv_setpvn(sv, (char *) buf, cnt);
3702 if (i != EOF && /* joy */
3704 SvCUR(sv) < rslen ||
3705 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3709 * If we're reading from a TTY and we get a short read,
3710 * indicating that the user hit his EOF character, we need
3711 * to notice it now, because if we try to read from the TTY
3712 * again, the EOF condition will disappear.
3714 * The comparison of cnt to sizeof(buf) is an optimization
3715 * that prevents unnecessary calls to feof().
3719 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3724 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3725 while (i != EOF) { /* to make sure file boundaries work right */
3726 i = PerlIO_getc(fp);
3728 PerlIO_ungetc(fp,i);
3735 win32_strip_return(sv);
3738 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3743 sv_inc(register SV *sv)
3752 if (SvTHINKFIRST(sv)) {
3753 if (SvREADONLY(sv)) {
3755 if (PL_curcop != &PL_compiling)
3756 croak(PL_no_modify);
3760 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3767 flags = SvFLAGS(sv);
3768 if (flags & SVp_NOK) {
3769 (void)SvNOK_only(sv);
3773 if (flags & SVp_IOK) {
3775 if (SvUVX(sv) == UV_MAX)
3776 sv_setnv(sv, (double)UV_MAX + 1.0);
3778 (void)SvIOK_only_UV(sv);
3781 if (SvIVX(sv) == IV_MAX)
3782 sv_setnv(sv, (double)IV_MAX + 1.0);
3784 (void)SvIOK_only(sv);
3790 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3791 if ((flags & SVTYPEMASK) < SVt_PVNV)
3792 sv_upgrade(sv, SVt_NV);
3794 (void)SvNOK_only(sv);
3798 while (isALPHA(*d)) d++;
3799 while (isDIGIT(*d)) d++;
3801 SET_NUMERIC_STANDARD();
3802 sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
3806 while (d >= SvPVX(sv)) {
3814 /* MKS: The original code here died if letters weren't consecutive.
3815 * at least it didn't have to worry about non-C locales. The
3816 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3817 * arranged in order (although not consecutively) and that only
3818 * [A-Za-z] are accepted by isALPHA in the C locale.
3820 if (*d != 'z' && *d != 'Z') {
3821 do { ++*d; } while (!isALPHA(*d));
3824 *(d--) -= 'z' - 'a';
3829 *(d--) -= 'z' - 'a' + 1;
3833 /* oh,oh, the number grew */
3834 SvGROW(sv, SvCUR(sv) + 2);
3836 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3845 sv_dec(register SV *sv)
3853 if (SvTHINKFIRST(sv)) {
3854 if (SvREADONLY(sv)) {
3856 if (PL_curcop != &PL_compiling)
3857 croak(PL_no_modify);
3861 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3868 flags = SvFLAGS(sv);
3869 if (flags & SVp_NOK) {
3871 (void)SvNOK_only(sv);
3874 if (flags & SVp_IOK) {
3876 if (SvUVX(sv) == 0) {
3877 (void)SvIOK_only(sv);
3881 (void)SvIOK_only_UV(sv);
3885 if (SvIVX(sv) == IV_MIN)
3886 sv_setnv(sv, (double)IV_MIN - 1.0);
3888 (void)SvIOK_only(sv);
3894 if (!(flags & SVp_POK)) {
3895 if ((flags & SVTYPEMASK) < SVt_PVNV)
3896 sv_upgrade(sv, SVt_NV);
3898 (void)SvNOK_only(sv);
3901 SET_NUMERIC_STANDARD();
3902 sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
3905 /* Make a string that will exist for the duration of the expression
3906 * evaluation. Actually, it may have to last longer than that, but
3907 * hopefully we won't free it until it has been assigned to a
3908 * permanent location. */
3911 sv_mortalcopy(SV *oldstr)
3917 sv_setsv(sv,oldstr);
3919 PL_tmps_stack[++PL_tmps_ix] = sv;
3931 SvFLAGS(sv) = SVs_TEMP;
3933 PL_tmps_stack[++PL_tmps_ix] = sv;
3937 /* same thing without the copying */
3940 sv_2mortal(register SV *sv)
3945 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3948 PL_tmps_stack[++PL_tmps_ix] = sv;
3954 newSVpv(const char *s, STRLEN len)
3961 sv_setpvn(sv,s,len);
3966 newSVpvn(const char *s, STRLEN len)
3971 sv_setpvn(sv,s,len);
3976 newSVpvf(const char* pat, ...)
3982 va_start(args, pat);
3983 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4010 newRV_noinc(SV *tmpRef)
4016 sv_upgrade(sv, SVt_RV);
4026 return newRV_noinc(SvREFCNT_inc(tmpRef));
4029 /* make an exact duplicate of old */
4032 newSVsv(register SV *old)
4038 if (SvTYPE(old) == SVTYPEMASK) {
4039 warn("semi-panic: attempt to dup freed string");
4054 sv_reset(register char *s, HV *stash)
4067 if (!*s) { /* reset ?? searches */
4068 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4069 pm->op_pmdynflags &= ~PMdf_USED;
4074 /* reset variables */
4076 if (!HvARRAY(stash))
4079 Zero(todo, 256, char);
4086 for ( ; i <= max; i++) {
4089 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4090 for (entry = HvARRAY(stash)[i];
4092 entry = HeNEXT(entry))
4094 if (!todo[(U8)*HeKEY(entry)])
4096 gv = (GV*)HeVAL(entry);
4098 if (SvTHINKFIRST(sv)) {
4099 if (!SvREADONLY(sv) && SvROK(sv))
4104 if (SvTYPE(sv) >= SVt_PV) {
4106 if (SvPVX(sv) != Nullch)
4113 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4115 #ifndef VMS /* VMS has no environ array */
4117 environ[0] = Nullch;
4132 switch (SvTYPE(sv)) {
4140 croak("Bad filehandle: %s", GvNAME(gv));
4144 croak(PL_no_usym, "filehandle");
4146 return sv_2io(SvRV(sv));
4147 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4153 croak("Bad filehandle: %s", SvPV(sv,n_a));
4160 sv_2cv(SV *sv, HV **st, GV **gvp, I32 lref)
4167 return *gvp = Nullgv, Nullcv;
4168 switch (SvTYPE(sv)) {
4188 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4189 tryAMAGICunDEREF(to_cv);
4192 if (SvTYPE(sv) == SVt_PVCV) {
4201 croak("Not a subroutine reference");
4206 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4212 if (lref && !GvCVu(gv)) {
4215 tmpsv = NEWSV(704,0);
4216 gv_efullname3(tmpsv, gv, Nullch);
4217 newSUB(start_subparse(FALSE, 0),
4218 newSVOP(OP_CONST, 0, tmpsv),
4223 croak("Unable to create sub named \"%s\"", SvPV(sv,n_a));
4230 sv_true(register SV *sv)
4237 if ((tXpv = (XPV*)SvANY(sv)) &&
4238 (*tXpv->xpv_pv > '0' ||
4239 tXpv->xpv_cur > 1 ||
4240 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4247 return SvIVX(sv) != 0;
4250 return SvNVX(sv) != 0.0;
4252 return sv_2bool(sv);
4258 sv_iv(register SV *sv)
4262 return (IV)SvUVX(sv);
4269 sv_uv(register SV *sv)
4274 return (UV)SvIVX(sv);
4280 sv_nv(register SV *sv)
4295 return sv_2pv(sv, &n_a);
4299 sv_pvn(SV *sv, STRLEN *lp)
4305 return sv_2pv(sv, lp);
4309 sv_pvn_force(SV *sv, STRLEN *lp)
4313 if (SvTHINKFIRST(sv) && !SvROK(sv))
4314 sv_force_normal(sv);
4320 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4322 croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
4323 PL_op_name[PL_op->op_type]);
4327 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4332 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4333 SvGROW(sv, len + 1);
4334 Move(s,SvPVX(sv),len,char);
4339 SvPOK_on(sv); /* validate pointer */
4341 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4342 (unsigned long)sv,SvPVX(sv)));
4349 sv_reftype(SV *sv, int ob)
4351 if (ob && SvOBJECT(sv))
4352 return HvNAME(SvSTASH(sv));
4354 switch (SvTYPE(sv)) {
4368 case SVt_PVLV: return "LVALUE";
4369 case SVt_PVAV: return "ARRAY";
4370 case SVt_PVHV: return "HASH";
4371 case SVt_PVCV: return "CODE";
4372 case SVt_PVGV: return "GLOB";
4373 case SVt_PVFM: return "FORMAT";
4374 default: return "UNKNOWN";
4395 sv_isa(SV *sv, const char *name)
4407 return strEQ(HvNAME(SvSTASH(sv)), name);
4411 newSVrv(SV *rv, const char *classname)
4418 SV_CHECK_THINKFIRST(rv);
4421 if (SvTYPE(rv) < SVt_RV)
4422 sv_upgrade(rv, SVt_RV);
4429 HV* stash = gv_stashpv(classname, TRUE);
4430 (void)sv_bless(rv, stash);
4436 sv_setref_pv(SV *rv, const char *classname, void *pv)
4439 sv_setsv(rv, &PL_sv_undef);
4443 sv_setiv(newSVrv(rv,classname), (IV)pv);
4448 sv_setref_iv(SV *rv, const char *classname, IV iv)
4450 sv_setiv(newSVrv(rv,classname), iv);
4455 sv_setref_nv(SV *rv, const char *classname, double nv)
4457 sv_setnv(newSVrv(rv,classname), nv);
4462 sv_setref_pvn(SV *rv, const char *classname, char *pv, STRLEN n)
4464 sv_setpvn(newSVrv(rv,classname), pv, n);
4469 sv_bless(SV *sv, HV *stash)
4474 croak("Can't bless non-reference value");
4476 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4477 if (SvREADONLY(tmpRef))
4478 croak(PL_no_modify);
4479 if (SvOBJECT(tmpRef)) {
4480 if (SvTYPE(tmpRef) != SVt_PVIO)
4482 SvREFCNT_dec(SvSTASH(tmpRef));
4485 SvOBJECT_on(tmpRef);
4486 if (SvTYPE(tmpRef) != SVt_PVIO)
4488 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4489 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4502 assert(SvTYPE(sv) == SVt_PVGV);
4507 SvREFCNT_dec(GvSTASH(sv));
4508 GvSTASH(sv) = Nullhv;
4510 sv_unmagic(sv, '*');
4511 Safefree(GvNAME(sv));
4513 SvFLAGS(sv) &= ~SVTYPEMASK;
4514 SvFLAGS(sv) |= SVt_PVMG;
4522 if (SvWEAKREF(sv)) {
4530 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4533 sv_2mortal(rv); /* Schedule for freeing later */
4539 sv_magic((sv), Nullsv, 't', Nullch, 0);
4545 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4546 MAGIC *mg = mg_find(sv, 't');
4555 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4556 MAGIC *mg = mg_find(sv, 't');
4557 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4564 sv_setpviv(SV *sv, IV iv)
4566 char buf[TYPE_CHARS(UV)];
4568 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4570 sv_setpvn(sv, ptr, ebuf - ptr);
4575 sv_setpviv_mg(SV *sv, IV iv)
4577 char buf[TYPE_CHARS(UV)];
4579 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4581 sv_setpvn(sv, ptr, ebuf - ptr);
4586 sv_setpvf(SV *sv, const char* pat, ...)
4589 va_start(args, pat);
4590 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4596 sv_setpvf_mg(SV *sv, const char* pat, ...)
4599 va_start(args, pat);
4600 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4606 sv_catpvf(SV *sv, const char* pat, ...)
4609 va_start(args, pat);
4610 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4615 sv_catpvf_mg(SV *sv, const char* pat, ...)
4618 va_start(args, pat);
4619 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4625 sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4627 sv_setpvn(sv, "", 0);
4628 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4632 sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4640 static char nullstr[] = "(null)";
4642 /* no matter what, this is a string now */
4643 (void)SvPV_force(sv, origlen);
4645 /* special-case "", "%s", and "%_" */
4648 if (patlen == 2 && pat[0] == '%') {
4652 char *s = va_arg(*args, char*);
4653 sv_catpv(sv, s ? s : nullstr);
4655 else if (svix < svmax)
4656 sv_catsv(sv, *svargs);
4660 sv_catsv(sv, va_arg(*args, SV*));
4663 /* See comment on '_' below */
4668 patend = (char*)pat + patlen;
4669 for (p = (char*)pat; p < patend; p = q) {
4677 bool has_precis = FALSE;
4682 STRLEN esignlen = 0;
4684 char *eptr = Nullch;
4686 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4697 for (q = p; q < patend && *q != '%'; ++q) ;
4699 sv_catpvn(sv, p, q - p);
4737 case '1': case '2': case '3':
4738 case '4': case '5': case '6':
4739 case '7': case '8': case '9':
4742 width = width * 10 + (*q++ - '0');
4747 i = va_arg(*args, int);
4749 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4751 width = (i < 0) ? -i : i;
4762 i = va_arg(*args, int);
4764 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4765 precis = (i < 0) ? 0 : i;
4771 precis = precis * 10 + (*q++ - '0');
4780 #if 0 /* when quads have better support within Perl */
4781 if (*(q + 1) == 'l') {
4808 uv = va_arg(*args, int);
4810 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4812 eptr = (char*)utf8buf;
4813 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4817 c = va_arg(*args, int);
4819 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4826 eptr = va_arg(*args, char*);
4828 elen = strlen(eptr);
4831 elen = sizeof nullstr - 1;
4834 else if (svix < svmax) {
4835 eptr = SvPVx(svargs[svix++], elen);
4837 if (has_precis && precis < elen) {
4839 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4842 if (width) { /* fudge width (can't fudge elen) */
4843 width += elen - sv_len_utf8(svargs[svix - 1]);
4851 * The "%_" hack might have to be changed someday,
4852 * if ISO or ANSI decide to use '_' for something.
4853 * So we keep it hidden from users' code.
4857 eptr = SvPVx(va_arg(*args, SV*), elen);
4860 if (has_precis && elen > precis)
4868 uv = (UV)va_arg(*args, void*);
4870 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4881 case 'h': iv = (short)va_arg(*args, int); break;
4882 default: iv = va_arg(*args, int); break;
4883 case 'l': iv = va_arg(*args, long); break;
4884 case 'V': iv = va_arg(*args, IV); break;
4888 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4890 case 'h': iv = (short)iv; break;
4891 default: iv = (int)iv; break;
4892 case 'l': iv = (long)iv; break;
4899 esignbuf[esignlen++] = plus;
4903 esignbuf[esignlen++] = '-';
4933 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4934 default: uv = va_arg(*args, unsigned); break;
4935 case 'l': uv = va_arg(*args, unsigned long); break;
4936 case 'V': uv = va_arg(*args, UV); break;
4940 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4942 case 'h': uv = (unsigned short)uv; break;
4943 default: uv = (unsigned)uv; break;
4944 case 'l': uv = (unsigned long)uv; break;
4950 eptr = ebuf + sizeof ebuf;
4956 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
4962 esignbuf[esignlen++] = '0';
4963 esignbuf[esignlen++] = c; /* 'x' or 'X' */
4969 *--eptr = '0' + dig;
4971 if (alt && *eptr != '0')
4977 *--eptr = '0' + dig;
4979 if (alt && *eptr != '0')
4982 default: /* it had better be ten or less */
4985 *--eptr = '0' + dig;
4986 } while (uv /= base);
4989 elen = (ebuf + sizeof ebuf) - eptr;
4992 zeros = precis - elen;
4993 else if (precis == 0 && elen == 1 && *eptr == '0')
4998 /* FLOATING POINT */
5001 c = 'f'; /* maybe %F isn't supported here */
5007 /* This is evil, but floating point is even more evil */
5010 nv = va_arg(*args, double);
5012 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5015 if (c != 'e' && c != 'E') {
5017 (void)frexp(nv, &i);
5018 if (i == PERL_INT_MIN)
5019 die("panic: frexp");
5021 need = BIT_DIGITS(i);
5023 need += has_precis ? precis : 6; /* known default */
5027 need += 20; /* fudge factor */
5028 if (PL_efloatsize < need) {
5029 Safefree(PL_efloatbuf);
5030 PL_efloatsize = need + 20; /* more fudge */
5031 New(906, PL_efloatbuf, PL_efloatsize, char);
5034 eptr = ebuf + sizeof ebuf;
5039 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5044 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5056 (void)sprintf(PL_efloatbuf, eptr, nv);
5058 eptr = PL_efloatbuf;
5059 elen = strlen(PL_efloatbuf);
5063 * User-defined locales may include arbitrary characters.
5064 * And, unfortunately, some system may alloc the "C" locale
5065 * to be overridden by a malicious user.
5068 *used_locale = TRUE;
5069 #endif /* LC_NUMERIC */
5076 i = SvCUR(sv) - origlen;
5079 case 'h': *(va_arg(*args, short*)) = i; break;
5080 default: *(va_arg(*args, int*)) = i; break;
5081 case 'l': *(va_arg(*args, long*)) = i; break;
5082 case 'V': *(va_arg(*args, IV*)) = i; break;
5085 else if (svix < svmax)
5086 sv_setuv(svargs[svix++], (UV)i);
5087 continue; /* not "break" */
5093 if (!args && ckWARN(WARN_PRINTF) &&
5094 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5095 SV *msg = sv_newmortal();
5096 sv_setpvf(msg, "Invalid conversion in %s: ",
5097 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5099 sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5102 sv_catpv(msg, "end of string");
5103 warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5106 /* output mangled stuff ... */
5112 /* ... right here, because formatting flags should not apply */
5113 SvGROW(sv, SvCUR(sv) + elen + 1);
5115 memcpy(p, eptr, elen);
5118 SvCUR(sv) = p - SvPVX(sv);
5119 continue; /* not "break" */
5122 have = esignlen + zeros + elen;
5123 need = (have > width ? have : width);
5126 SvGROW(sv, SvCUR(sv) + need + 1);
5128 if (esignlen && fill == '0') {
5129 for (i = 0; i < esignlen; i++)
5133 memset(p, fill, gap);
5136 if (esignlen && fill != '0') {
5137 for (i = 0; i < esignlen; i++)
5141 for (i = zeros; i; i--)
5145 memcpy(p, eptr, elen);
5149 memset(p, ' ', gap);
5153 SvCUR(sv) = p - SvPVX(sv);