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 /* XXX this is probably not what they think they're getting.
4218 * It has the same effect as "sub name;", i.e. just a forward
4220 newSUB(start_subparse(FALSE, 0),
4221 newSVOP(OP_CONST, 0, tmpsv),
4226 croak("Unable to create sub named \"%s\"", SvPV(sv,n_a));
4233 sv_true(register SV *sv)
4240 if ((tXpv = (XPV*)SvANY(sv)) &&
4241 (*tXpv->xpv_pv > '0' ||
4242 tXpv->xpv_cur > 1 ||
4243 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4250 return SvIVX(sv) != 0;
4253 return SvNVX(sv) != 0.0;
4255 return sv_2bool(sv);
4261 sv_iv(register SV *sv)
4265 return (IV)SvUVX(sv);
4272 sv_uv(register SV *sv)
4277 return (UV)SvIVX(sv);
4283 sv_nv(register SV *sv)
4298 return sv_2pv(sv, &n_a);
4302 sv_pvn(SV *sv, STRLEN *lp)
4308 return sv_2pv(sv, lp);
4312 sv_pvn_force(SV *sv, STRLEN *lp)
4316 if (SvTHINKFIRST(sv) && !SvROK(sv))
4317 sv_force_normal(sv);
4323 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4325 croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
4326 PL_op_name[PL_op->op_type]);
4330 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4335 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4336 SvGROW(sv, len + 1);
4337 Move(s,SvPVX(sv),len,char);
4342 SvPOK_on(sv); /* validate pointer */
4344 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4345 (unsigned long)sv,SvPVX(sv)));
4352 sv_reftype(SV *sv, int ob)
4354 if (ob && SvOBJECT(sv))
4355 return HvNAME(SvSTASH(sv));
4357 switch (SvTYPE(sv)) {
4371 case SVt_PVLV: return "LVALUE";
4372 case SVt_PVAV: return "ARRAY";
4373 case SVt_PVHV: return "HASH";
4374 case SVt_PVCV: return "CODE";
4375 case SVt_PVGV: return "GLOB";
4376 case SVt_PVFM: return "FORMAT";
4377 default: return "UNKNOWN";
4398 sv_isa(SV *sv, const char *name)
4410 return strEQ(HvNAME(SvSTASH(sv)), name);
4414 newSVrv(SV *rv, const char *classname)
4421 SV_CHECK_THINKFIRST(rv);
4424 if (SvTYPE(rv) < SVt_RV)
4425 sv_upgrade(rv, SVt_RV);
4432 HV* stash = gv_stashpv(classname, TRUE);
4433 (void)sv_bless(rv, stash);
4439 sv_setref_pv(SV *rv, const char *classname, void *pv)
4442 sv_setsv(rv, &PL_sv_undef);
4446 sv_setiv(newSVrv(rv,classname), (IV)pv);
4451 sv_setref_iv(SV *rv, const char *classname, IV iv)
4453 sv_setiv(newSVrv(rv,classname), iv);
4458 sv_setref_nv(SV *rv, const char *classname, double nv)
4460 sv_setnv(newSVrv(rv,classname), nv);
4465 sv_setref_pvn(SV *rv, const char *classname, char *pv, STRLEN n)
4467 sv_setpvn(newSVrv(rv,classname), pv, n);
4472 sv_bless(SV *sv, HV *stash)
4477 croak("Can't bless non-reference value");
4479 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4480 if (SvREADONLY(tmpRef))
4481 croak(PL_no_modify);
4482 if (SvOBJECT(tmpRef)) {
4483 if (SvTYPE(tmpRef) != SVt_PVIO)
4485 SvREFCNT_dec(SvSTASH(tmpRef));
4488 SvOBJECT_on(tmpRef);
4489 if (SvTYPE(tmpRef) != SVt_PVIO)
4491 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4492 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4505 assert(SvTYPE(sv) == SVt_PVGV);
4510 SvREFCNT_dec(GvSTASH(sv));
4511 GvSTASH(sv) = Nullhv;
4513 sv_unmagic(sv, '*');
4514 Safefree(GvNAME(sv));
4516 SvFLAGS(sv) &= ~SVTYPEMASK;
4517 SvFLAGS(sv) |= SVt_PVMG;
4525 if (SvWEAKREF(sv)) {
4533 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4536 sv_2mortal(rv); /* Schedule for freeing later */
4542 sv_magic((sv), Nullsv, 't', Nullch, 0);
4548 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4549 MAGIC *mg = mg_find(sv, 't');
4558 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4559 MAGIC *mg = mg_find(sv, 't');
4560 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4567 sv_setpviv(SV *sv, IV iv)
4569 char buf[TYPE_CHARS(UV)];
4571 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4573 sv_setpvn(sv, ptr, ebuf - ptr);
4578 sv_setpviv_mg(SV *sv, IV iv)
4580 char buf[TYPE_CHARS(UV)];
4582 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4584 sv_setpvn(sv, ptr, ebuf - ptr);
4589 sv_setpvf(SV *sv, const char* pat, ...)
4592 va_start(args, pat);
4593 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4599 sv_setpvf_mg(SV *sv, const char* pat, ...)
4602 va_start(args, pat);
4603 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4609 sv_catpvf(SV *sv, const char* pat, ...)
4612 va_start(args, pat);
4613 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4618 sv_catpvf_mg(SV *sv, const char* pat, ...)
4621 va_start(args, pat);
4622 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4628 sv_vsetpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4630 sv_setpvn(sv, "", 0);
4631 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4635 sv_vcatpvfn(SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4643 static char nullstr[] = "(null)";
4645 /* no matter what, this is a string now */
4646 (void)SvPV_force(sv, origlen);
4648 /* special-case "", "%s", and "%_" */
4651 if (patlen == 2 && pat[0] == '%') {
4655 char *s = va_arg(*args, char*);
4656 sv_catpv(sv, s ? s : nullstr);
4658 else if (svix < svmax)
4659 sv_catsv(sv, *svargs);
4663 sv_catsv(sv, va_arg(*args, SV*));
4666 /* See comment on '_' below */
4671 patend = (char*)pat + patlen;
4672 for (p = (char*)pat; p < patend; p = q) {
4680 bool has_precis = FALSE;
4685 STRLEN esignlen = 0;
4687 char *eptr = Nullch;
4689 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4700 for (q = p; q < patend && *q != '%'; ++q) ;
4702 sv_catpvn(sv, p, q - p);
4740 case '1': case '2': case '3':
4741 case '4': case '5': case '6':
4742 case '7': case '8': case '9':
4745 width = width * 10 + (*q++ - '0');
4750 i = va_arg(*args, int);
4752 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4754 width = (i < 0) ? -i : i;
4765 i = va_arg(*args, int);
4767 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4768 precis = (i < 0) ? 0 : i;
4774 precis = precis * 10 + (*q++ - '0');
4783 #if 0 /* when quads have better support within Perl */
4784 if (*(q + 1) == 'l') {
4811 uv = va_arg(*args, int);
4813 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4815 eptr = (char*)utf8buf;
4816 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4820 c = va_arg(*args, int);
4822 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4829 eptr = va_arg(*args, char*);
4831 elen = strlen(eptr);
4834 elen = sizeof nullstr - 1;
4837 else if (svix < svmax) {
4838 eptr = SvPVx(svargs[svix++], elen);
4840 if (has_precis && precis < elen) {
4842 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4845 if (width) { /* fudge width (can't fudge elen) */
4846 width += elen - sv_len_utf8(svargs[svix - 1]);
4854 * The "%_" hack might have to be changed someday,
4855 * if ISO or ANSI decide to use '_' for something.
4856 * So we keep it hidden from users' code.
4860 eptr = SvPVx(va_arg(*args, SV*), elen);
4863 if (has_precis && elen > precis)
4871 uv = (UV)va_arg(*args, void*);
4873 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4884 case 'h': iv = (short)va_arg(*args, int); break;
4885 default: iv = va_arg(*args, int); break;
4886 case 'l': iv = va_arg(*args, long); break;
4887 case 'V': iv = va_arg(*args, IV); break;
4891 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4893 case 'h': iv = (short)iv; break;
4894 default: iv = (int)iv; break;
4895 case 'l': iv = (long)iv; break;
4902 esignbuf[esignlen++] = plus;
4906 esignbuf[esignlen++] = '-';
4936 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4937 default: uv = va_arg(*args, unsigned); break;
4938 case 'l': uv = va_arg(*args, unsigned long); break;
4939 case 'V': uv = va_arg(*args, UV); break;
4943 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4945 case 'h': uv = (unsigned short)uv; break;
4946 default: uv = (unsigned)uv; break;
4947 case 'l': uv = (unsigned long)uv; break;
4953 eptr = ebuf + sizeof ebuf;
4959 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
4965 esignbuf[esignlen++] = '0';
4966 esignbuf[esignlen++] = c; /* 'x' or 'X' */
4972 *--eptr = '0' + dig;
4974 if (alt && *eptr != '0')
4980 *--eptr = '0' + dig;
4982 if (alt && *eptr != '0')
4985 default: /* it had better be ten or less */
4988 *--eptr = '0' + dig;
4989 } while (uv /= base);
4992 elen = (ebuf + sizeof ebuf) - eptr;
4995 zeros = precis - elen;
4996 else if (precis == 0 && elen == 1 && *eptr == '0')
5001 /* FLOATING POINT */
5004 c = 'f'; /* maybe %F isn't supported here */
5010 /* This is evil, but floating point is even more evil */
5013 nv = va_arg(*args, double);
5015 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5018 if (c != 'e' && c != 'E') {
5020 (void)frexp(nv, &i);
5021 if (i == PERL_INT_MIN)
5022 die("panic: frexp");
5024 need = BIT_DIGITS(i);
5026 need += has_precis ? precis : 6; /* known default */
5030 need += 20; /* fudge factor */
5031 if (PL_efloatsize < need) {
5032 Safefree(PL_efloatbuf);
5033 PL_efloatsize = need + 20; /* more fudge */
5034 New(906, PL_efloatbuf, PL_efloatsize, char);
5037 eptr = ebuf + sizeof ebuf;
5042 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5047 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5059 (void)sprintf(PL_efloatbuf, eptr, nv);
5061 eptr = PL_efloatbuf;
5062 elen = strlen(PL_efloatbuf);
5066 * User-defined locales may include arbitrary characters.
5067 * And, unfortunately, some system may alloc the "C" locale
5068 * to be overridden by a malicious user.
5071 *used_locale = TRUE;
5072 #endif /* LC_NUMERIC */
5079 i = SvCUR(sv) - origlen;
5082 case 'h': *(va_arg(*args, short*)) = i; break;
5083 default: *(va_arg(*args, int*)) = i; break;
5084 case 'l': *(va_arg(*args, long*)) = i; break;
5085 case 'V': *(va_arg(*args, IV*)) = i; break;
5088 else if (svix < svmax)
5089 sv_setuv(svargs[svix++], (UV)i);
5090 continue; /* not "break" */
5096 if (!args && ckWARN(WARN_PRINTF) &&
5097 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5098 SV *msg = sv_newmortal();
5099 sv_setpvf(msg, "Invalid conversion in %s: ",
5100 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5102 sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5105 sv_catpv(msg, "end of string");
5106 warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5109 /* output mangled stuff ... */
5115 /* ... right here, because formatting flags should not apply */
5116 SvGROW(sv, SvCUR(sv) + elen + 1);
5118 memcpy(p, eptr, elen);
5121 SvCUR(sv) = p - SvPVX(sv);
5122 continue; /* not "break" */
5125 have = esignlen + zeros + elen;
5126 need = (have > width ? have : width);
5129 SvGROW(sv, SvCUR(sv) + need + 1);
5131 if (esignlen && fill == '0') {
5132 for (i = 0; i < esignlen; i++)
5136 memset(p, fill, gap);
5139 if (esignlen && fill != '0') {
5140 for (i = 0; i < esignlen; i++)
5144 for (i = zeros; i; i--)
5148 memcpy(p, eptr, elen);
5152 memset(p, ' ', gap);
5156 SvCUR(sv) = p - SvPVX(sv);