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.
19 /* Use an overridden DBL_DIG */
23 # define DBL_DIG OVR_DBL_DIG
25 /* The following is all to get DBL_DIG, in order to pick a nice
26 default value for printing floating point numbers in Gconvert.
36 #define DBL_DIG 15 /* A guess that works lots of places */
41 #define FCALL this->*f
42 #define VTBL this->*vtbl
43 #else /* !PERL_OBJECT */
46 #endif /* PERL_OBJECT */
48 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
55 (p) = (SV*)safemalloc(sizeof(SV)); \
67 Safefree((char*)(p)); \
72 static I32 registry_size;
74 #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
76 #define REG_REPLACE(sv,a,b) \
78 void* p = sv->sv_any; \
79 I32 h = REGHASH(sv, registry_size); \
81 while (registry[i] != (a)) { \
82 if (++i >= registry_size) \
85 die("SV registry bug"); \
90 #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
91 #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
96 if (PL_sv_count >= (registry_size >> 1))
98 SV **oldreg = registry;
99 I32 oldsize = registry_size;
101 registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
102 Newz(707, registry, registry_size, SV*);
107 for (i = 0; i < oldsize; ++i) {
108 SV* oldsv = oldreg[i];
121 reg_remove(pTHX_ SV *sv)
128 visit(pTHX_ SVFUNC_t f)
132 for (i = 0; i < registry_size; ++i) {
133 SV* sv = registry[i];
134 if (sv && SvTYPE(sv) != SVTYPEMASK)
140 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
142 if (!(flags & SVf_FAKE))
149 * "A time to plant, and a time to uproot what was planted..."
152 #define plant_SV(p) \
154 SvANY(p) = (void *)PL_sv_root; \
155 SvFLAGS(p) = SVTYPEMASK; \
160 /* sv_mutex must be held while calling uproot_SV() */
161 #define uproot_SV(p) \
164 PL_sv_root = (SV*)SvANY(p); \
186 if (PL_debug & 32768) \
196 if (PL_debug & 32768) {
201 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
203 svend = &sva[SvREFCNT(sva)];
204 if (p >= sv && p < svend)
208 warn("Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
215 #else /* ! DEBUGGING */
217 #define del_SV(p) plant_SV(p)
219 #endif /* DEBUGGING */
222 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
227 Zero(sva, size, char);
229 /* The first SV in an arena isn't an SV. */
230 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
231 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
232 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
234 PL_sv_arenaroot = sva;
235 PL_sv_root = sva + 1;
237 svend = &sva[SvREFCNT(sva) - 1];
240 SvANY(sv) = (void *)(SV*)(sv + 1);
241 SvFLAGS(sv) = SVTYPEMASK;
245 SvFLAGS(sv) = SVTYPEMASK;
248 /* sv_mutex must be held while calling more_sv() */
255 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
256 PL_nice_chunk = Nullch;
259 char *chunk; /* must use New here to match call to */
260 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
261 sv_add_arena(chunk, 1008, 0);
268 visit(pTHX_ SVFUNC_t f)
274 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
275 svend = &sva[SvREFCNT(sva)];
276 for (sv = sva + 1; sv < svend; ++sv) {
277 if (SvTYPE(sv) != SVTYPEMASK)
286 do_report_used(pTHX_ SV *sv)
288 if (SvTYPE(sv) != SVTYPEMASK) {
289 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
290 PerlIO_printf(PerlIO_stderr(), "****\n");
296 Perl_sv_report_used(pTHX)
298 visit(FUNC_NAME_TO_PTR(do_report_used));
302 do_clean_objs(pTHX_ SV *sv)
306 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
307 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
313 /* XXX Might want to check arrays, etc. */
316 #ifndef DISABLE_DESTRUCTOR_KLUDGE
318 do_clean_named_objs(pTHX_ SV *sv)
320 if (SvTYPE(sv) == SVt_PVGV) {
321 if ( SvOBJECT(GvSV(sv)) ||
322 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
323 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
324 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
325 GvCV(sv) && SvOBJECT(GvCV(sv)) )
327 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
335 Perl_sv_clean_objs(pTHX)
337 PL_in_clean_objs = TRUE;
338 visit(FUNC_NAME_TO_PTR(do_clean_objs));
339 #ifndef DISABLE_DESTRUCTOR_KLUDGE
340 /* some barnacles may yet remain, clinging to typeglobs */
341 visit(FUNC_NAME_TO_PTR(do_clean_named_objs));
343 PL_in_clean_objs = FALSE;
347 do_clean_all(pTHX_ SV *sv)
349 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
350 SvFLAGS(sv) |= SVf_BREAK;
355 Perl_sv_clean_all(pTHX)
357 PL_in_clean_all = TRUE;
358 visit(FUNC_NAME_TO_PTR(do_clean_all));
359 PL_in_clean_all = FALSE;
363 Perl_sv_free_arenas(pTHX)
368 /* Free arenas here, but be careful about fake ones. (We assume
369 contiguity of the fake ones with the corresponding real ones.) */
371 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
372 svanext = (SV*) SvANY(sva);
373 while (svanext && SvFAKE(svanext))
374 svanext = (SV*) SvANY(svanext);
377 Safefree((void *)sva);
381 Safefree(PL_nice_chunk);
382 PL_nice_chunk = Nullch;
383 PL_nice_chunk_size = 0;
397 * See comment in more_xiv() -- RAM.
399 PL_xiv_root = *(IV**)xiv;
401 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
405 del_xiv(pTHX_ XPVIV *p)
407 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
409 *(IV**)xiv = PL_xiv_root;
420 New(705, ptr, 1008/sizeof(XPV), XPV);
421 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
422 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
425 xivend = &xiv[1008 / sizeof(IV) - 1];
426 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
428 while (xiv < xivend) {
429 *(IV**)xiv = (IV *)(xiv + 1);
443 PL_xnv_root = *(double**)xnv;
445 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
449 del_xnv(pTHX_ XPVNV *p)
451 double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
453 *(double**)xnv = PL_xnv_root;
461 register double* xnv;
462 register double* xnvend;
463 New(711, xnv, 1008/sizeof(double), double);
464 xnvend = &xnv[1008 / sizeof(double) - 1];
465 xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */
467 while (xnv < xnvend) {
468 *(double**)xnv = (double*)(xnv + 1);
482 PL_xrv_root = (XRV*)xrv->xrv_rv;
488 del_xrv(pTHX_ XRV *p)
491 p->xrv_rv = (SV*)PL_xrv_root;
500 register XRV* xrvend;
501 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
503 xrvend = &xrv[1008 / sizeof(XRV) - 1];
504 while (xrv < xrvend) {
505 xrv->xrv_rv = (SV*)(xrv + 1);
519 PL_xpv_root = (XPV*)xpv->xpv_pv;
525 del_xpv(pTHX_ XPV *p)
528 p->xpv_pv = (char*)PL_xpv_root;
537 register XPV* xpvend;
538 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
540 xpvend = &xpv[1008 / sizeof(XPV) - 1];
541 while (xpv < xpvend) {
542 xpv->xpv_pv = (char*)(xpv + 1);
549 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
550 #define del_XIV(p) Safefree((char*)p)
552 #define new_XIV() (void*)new_xiv()
553 #define del_XIV(p) del_xiv((XPVIV*) p)
557 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
558 #define del_XNV(p) Safefree((char*)p)
560 #define new_XNV() (void*)new_xnv()
561 #define del_XNV(p) del_xnv((XPVNV*) p)
565 #define new_XRV() (void*)safemalloc(sizeof(XRV))
566 #define del_XRV(p) Safefree((char*)p)
568 #define new_XRV() (void*)new_xrv()
569 #define del_XRV(p) del_xrv((XRV*) p)
573 #define new_XPV() (void*)safemalloc(sizeof(XPV))
574 #define del_XPV(p) Safefree((char*)p)
576 #define new_XPV() (void*)new_xpv()
577 #define del_XPV(p) del_xpv((XPV *)p)
581 # define my_safemalloc(s) safemalloc(s)
582 # define my_safefree(s) safefree(s)
585 my_safemalloc(pTHX_ MEM_SIZE size)
588 New(717, p, size, char);
591 # define my_safefree(s) Safefree(s)
594 #define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
595 #define del_XPVIV(p) my_safefree((char*)p)
597 #define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
598 #define del_XPVNV(p) my_safefree((char*)p)
600 #define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
601 #define del_XPVMG(p) my_safefree((char*)p)
603 #define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
604 #define del_XPVLV(p) my_safefree((char*)p)
606 #define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
607 #define del_XPVAV(p) my_safefree((char*)p)
609 #define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
610 #define del_XPVHV(p) my_safefree((char*)p)
612 #define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
613 #define del_XPVCV(p) my_safefree((char*)p)
615 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
616 #define del_XPVGV(p) my_safefree((char*)p)
618 #define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
619 #define del_XPVBM(p) my_safefree((char*)p)
621 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
622 #define del_XPVFM(p) my_safefree((char*)p)
624 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
625 #define del_XPVIO(p) my_safefree((char*)p)
628 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
638 if (SvTYPE(sv) == mt)
644 switch (SvTYPE(sv)) {
659 nv = (double)SvIVX(sv);
665 else if (mt < SVt_PVIV)
682 pv = (char*)SvRV(sv);
686 nv = (double)(unsigned long)pv;
702 else if (mt == SVt_NV)
713 del_XPVIV(SvANY(sv));
723 del_XPVNV(SvANY(sv));
733 del_XPVMG(SvANY(sv));
736 croak("Can't upgrade that kind of scalar");
741 croak("Can't upgrade to undef");
743 SvANY(sv) = new_XIV();
747 SvANY(sv) = new_XNV();
751 SvANY(sv) = new_XRV();
755 SvANY(sv) = new_XPV();
761 SvANY(sv) = new_XPVIV();
771 SvANY(sv) = new_XPVNV();
779 SvANY(sv) = new_XPVMG();
789 SvANY(sv) = new_XPVLV();
803 SvANY(sv) = new_XPVAV();
818 SvANY(sv) = new_XPVHV();
834 SvANY(sv) = new_XPVCV();
835 Zero(SvANY(sv), 1, XPVCV);
845 SvANY(sv) = new_XPVGV();
860 SvANY(sv) = new_XPVBM();
873 SvANY(sv) = new_XPVFM();
874 Zero(SvANY(sv), 1, XPVFM);
884 SvANY(sv) = new_XPVIO();
885 Zero(SvANY(sv), 1, XPVIO);
896 SvFLAGS(sv) &= ~SVTYPEMASK;
902 Perl_sv_backoff(pTHX_ register SV *sv)
907 SvLEN(sv) += SvIVX(sv);
908 SvPVX(sv) -= SvIVX(sv);
910 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
912 SvFLAGS(sv) &= ~SVf_OOK;
917 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
922 if (newlen >= 0x10000) {
923 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
926 #endif /* HAS_64K_LIMIT */
929 if (SvTYPE(sv) < SVt_PV) {
930 sv_upgrade(sv, SVt_PV);
933 else if (SvOOK(sv)) { /* pv is offset? */
936 if (newlen > SvLEN(sv))
937 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
939 if (newlen >= 0x10000)
945 if (newlen > SvLEN(sv)) { /* need more room? */
946 if (SvLEN(sv) && s) {
947 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
948 STRLEN l = malloced_size((void*)SvPVX(sv));
954 Renew(s,newlen,char);
957 New(703,s,newlen,char);
959 SvLEN_set(sv, newlen);
965 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
967 SV_CHECK_THINKFIRST(sv);
968 switch (SvTYPE(sv)) {
970 sv_upgrade(sv, SVt_IV);
973 sv_upgrade(sv, SVt_PVNV);
977 sv_upgrade(sv, SVt_PVIV);
988 croak("Can't coerce %s to integer in %s", sv_reftype(sv,0),
989 PL_op_desc[PL_op->op_type]);
992 (void)SvIOK_only(sv); /* validate number */
998 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1005 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1013 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1020 Perl_sv_setnv(pTHX_ register SV *sv, double num)
1022 SV_CHECK_THINKFIRST(sv);
1023 switch (SvTYPE(sv)) {
1026 sv_upgrade(sv, SVt_NV);
1031 sv_upgrade(sv, SVt_PVNV);
1042 croak("Can't coerce %s to number in %s", sv_reftype(sv,0),
1043 PL_op_name[PL_op->op_type]);
1047 (void)SvNOK_only(sv); /* validate number */
1052 Perl_sv_setnv_mg(pTHX_ register SV *sv, double num)
1059 not_a_number(pTHX_ SV *sv)
1065 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1066 /* each *s can expand to 4 chars + "...\0",
1067 i.e. need room for 8 chars */
1069 for (s = SvPVX(sv); *s && d < limit; s++) {
1071 if (ch & 128 && !isPRINT_LC(ch)) {
1080 else if (ch == '\r') {
1084 else if (ch == '\f') {
1088 else if (ch == '\\') {
1092 else if (isPRINT_LC(ch))
1107 warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
1108 PL_op_name[PL_op->op_type]);
1110 warner(WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
1113 /* the number can be converted to _integer_ with atol() */
1114 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1115 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1116 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1117 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1119 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1120 until proven guilty, assume that things are not that bad... */
1123 Perl_sv_2iv(pTHX_ register SV *sv)
1127 if (SvGMAGICAL(sv)) {
1132 return I_V(SvNVX(sv));
1134 if (SvPOKp(sv) && SvLEN(sv))
1137 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1139 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1140 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1145 if (SvTHINKFIRST(sv)) {
1148 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1149 return SvIV(tmpstr);
1150 return (IV)SvRV(sv);
1152 if (SvREADONLY(sv)) {
1154 return I_V(SvNVX(sv));
1156 if (SvPOKp(sv) && SvLEN(sv))
1160 if (ckWARN(WARN_UNINITIALIZED))
1161 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1168 return (IV)(SvUVX(sv));
1175 /* We can cache the IV/UV value even if it not good enough
1176 * to reconstruct NV, since the conversion to PV will prefer
1177 * NV over IV/UV. XXXX 64-bit?
1180 if (SvTYPE(sv) == SVt_NV)
1181 sv_upgrade(sv, SVt_PVNV);
1184 if (SvNVX(sv) < (double)IV_MAX + 0.5)
1185 SvIVX(sv) = I_V(SvNVX(sv));
1187 SvUVX(sv) = U_V(SvNVX(sv));
1190 DEBUG_c(PerlIO_printf(Perl_debug_log,
1191 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1193 (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
1194 return (IV)SvUVX(sv);
1197 else if (SvPOKp(sv) && SvLEN(sv)) {
1198 I32 numtype = looks_like_number(sv);
1200 /* We want to avoid a possible problem when we cache an IV which
1201 may be later translated to an NV, and the resulting NV is not
1202 the translation of the initial data.
1204 This means that if we cache such an IV, we need to cache the
1205 NV as well. Moreover, we trade speed for space, and do not
1206 cache the NV if not needed.
1208 if (numtype & IS_NUMBER_NOT_IV) {
1209 /* May be not an integer. Need to cache NV if we cache IV
1210 * - otherwise future conversion to NV will be wrong. */
1213 SET_NUMERIC_STANDARD();
1214 d = atof(SvPVX(sv));
1216 if (SvTYPE(sv) < SVt_PVNV)
1217 sv_upgrade(sv, SVt_PVNV);
1221 DEBUG_c(PerlIO_printf(Perl_debug_log,
1222 "0x%lx 2nv(%g)\n",(unsigned long)sv,
1224 if (SvNVX(sv) < (double)IV_MAX + 0.5)
1225 SvIVX(sv) = I_V(SvNVX(sv));
1227 SvUVX(sv) = U_V(SvNVX(sv));
1233 /* The NV may be reconstructed from IV - safe to cache IV,
1234 which may be calculated by atol(). */
1235 if (SvTYPE(sv) == SVt_PV)
1236 sv_upgrade(sv, SVt_PVIV);
1238 SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
1240 else { /* Not a number. Cache 0. */
1243 if (SvTYPE(sv) < SVt_PVIV)
1244 sv_upgrade(sv, SVt_PVIV);
1247 if (ckWARN(WARN_NUMERIC))
1253 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1254 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1255 if (SvTYPE(sv) < SVt_IV)
1256 /* Typically the caller expects that sv_any is not NULL now. */
1257 sv_upgrade(sv, SVt_IV);
1260 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1261 (unsigned long)sv,(long)SvIVX(sv)));
1262 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1266 Perl_sv_2uv(pTHX_ register SV *sv)
1270 if (SvGMAGICAL(sv)) {
1275 return U_V(SvNVX(sv));
1276 if (SvPOKp(sv) && SvLEN(sv))
1279 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1281 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1282 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1287 if (SvTHINKFIRST(sv)) {
1290 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1291 return SvUV(tmpstr);
1292 return (UV)SvRV(sv);
1294 if (SvREADONLY(sv)) {
1296 return U_V(SvNVX(sv));
1298 if (SvPOKp(sv) && SvLEN(sv))
1302 if (ckWARN(WARN_UNINITIALIZED))
1303 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1313 return (UV)SvIVX(sv);
1317 /* We can cache the IV/UV value even if it not good enough
1318 * to reconstruct NV, since the conversion to PV will prefer
1319 * NV over IV/UV. XXXX 64-bit?
1321 if (SvTYPE(sv) == SVt_NV)
1322 sv_upgrade(sv, SVt_PVNV);
1324 if (SvNVX(sv) >= -0.5) {
1326 SvUVX(sv) = U_V(SvNVX(sv));
1329 SvIVX(sv) = I_V(SvNVX(sv));
1331 DEBUG_c(PerlIO_printf(Perl_debug_log,
1332 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1333 (unsigned long)sv,(long)SvIVX(sv),
1334 (long)(UV)SvIVX(sv)));
1335 return (UV)SvIVX(sv);
1338 else if (SvPOKp(sv) && SvLEN(sv)) {
1339 I32 numtype = looks_like_number(sv);
1341 /* We want to avoid a possible problem when we cache a UV which
1342 may be later translated to an NV, and the resulting NV is not
1343 the translation of the initial data.
1345 This means that if we cache such a UV, we need to cache the
1346 NV as well. Moreover, we trade speed for space, and do not
1347 cache the NV if not needed.
1349 if (numtype & IS_NUMBER_NOT_IV) {
1350 /* May be not an integer. Need to cache NV if we cache IV
1351 * - otherwise future conversion to NV will be wrong. */
1354 SET_NUMERIC_STANDARD();
1355 d = atof(SvPVX(sv)); /* XXXX 64-bit? */
1357 if (SvTYPE(sv) < SVt_PVNV)
1358 sv_upgrade(sv, SVt_PVNV);
1362 DEBUG_c(PerlIO_printf(Perl_debug_log,
1363 "0x%lx 2nv(%g)\n",(unsigned long)sv,
1365 if (SvNVX(sv) < -0.5) {
1366 SvIVX(sv) = I_V(SvNVX(sv));
1369 SvUVX(sv) = U_V(SvNVX(sv));
1373 else if (numtype & IS_NUMBER_NEG) {
1374 /* The NV may be reconstructed from IV - safe to cache IV,
1375 which may be calculated by atol(). */
1376 if (SvTYPE(sv) == SVt_PV)
1377 sv_upgrade(sv, SVt_PVIV);
1379 SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1381 else if (numtype) { /* Non-negative */
1382 /* The NV may be reconstructed from UV - safe to cache UV,
1383 which may be calculated by strtoul()/atol. */
1384 if (SvTYPE(sv) == SVt_PV)
1385 sv_upgrade(sv, SVt_PVIV);
1387 (void)SvIsUV_on(sv);
1389 SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
1390 #else /* no atou(), but we know the number fits into IV... */
1391 /* The only problem may be if it is negative... */
1392 SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1395 else { /* Not a number. Cache 0. */
1398 if (SvTYPE(sv) < SVt_PVIV)
1399 sv_upgrade(sv, SVt_PVIV);
1400 SvUVX(sv) = 0; /* We assume that 0s have the
1401 same bitmap in IV and UV. */
1403 (void)SvIsUV_on(sv);
1404 if (ckWARN(WARN_NUMERIC))
1409 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1411 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1412 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1414 if (SvTYPE(sv) < SVt_IV)
1415 /* Typically the caller expects that sv_any is not NULL now. */
1416 sv_upgrade(sv, SVt_IV);
1420 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1421 (unsigned long)sv,SvUVX(sv)));
1422 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1426 Perl_sv_2nv(pTHX_ register SV *sv)
1430 if (SvGMAGICAL(sv)) {
1434 if (SvPOKp(sv) && SvLEN(sv)) {
1436 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1438 SET_NUMERIC_STANDARD();
1439 return atof(SvPVX(sv));
1443 return (double)SvUVX(sv);
1445 return (double)SvIVX(sv);
1448 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1450 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1451 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1456 if (SvTHINKFIRST(sv)) {
1459 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1460 return SvNV(tmpstr);
1461 return (double)(unsigned long)SvRV(sv);
1463 if (SvREADONLY(sv)) {
1465 if (SvPOKp(sv) && SvLEN(sv)) {
1466 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1468 SET_NUMERIC_STANDARD();
1469 return atof(SvPVX(sv));
1473 return (double)SvUVX(sv);
1475 return (double)SvIVX(sv);
1477 if (ckWARN(WARN_UNINITIALIZED))
1478 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1482 if (SvTYPE(sv) < SVt_NV) {
1483 if (SvTYPE(sv) == SVt_IV)
1484 sv_upgrade(sv, SVt_PVNV);
1486 sv_upgrade(sv, SVt_NV);
1487 DEBUG_c(SET_NUMERIC_STANDARD());
1488 DEBUG_c(PerlIO_printf(Perl_debug_log,
1489 "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
1491 else if (SvTYPE(sv) < SVt_PVNV)
1492 sv_upgrade(sv, SVt_PVNV);
1494 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1496 SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv);
1498 else if (SvPOKp(sv) && SvLEN(sv)) {
1500 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1502 SET_NUMERIC_STANDARD();
1503 SvNVX(sv) = atof(SvPVX(sv));
1507 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1508 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1509 if (SvTYPE(sv) < SVt_NV)
1510 /* Typically the caller expects that sv_any is not NULL now. */
1511 sv_upgrade(sv, SVt_NV);
1515 DEBUG_c(SET_NUMERIC_STANDARD());
1516 DEBUG_c(PerlIO_printf(Perl_debug_log,
1517 "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
1524 I32 numtype = looks_like_number(sv);
1527 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1528 return atol(SvPVX(sv)); /* XXXX 64-bit? */
1531 if (ckWARN(WARN_NUMERIC))
1534 SET_NUMERIC_STANDARD();
1535 d = atof(SvPVX(sv));
1542 I32 numtype = looks_like_number(sv);
1545 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1546 return strtoul(SvPVX(sv), Null(char**), 10);
1550 if (ckWARN(WARN_NUMERIC))
1553 SET_NUMERIC_STANDARD();
1554 return U_V(atof(SvPVX(sv)));
1558 * Returns a combination of (advisory only - can get false negatives)
1559 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1561 * 0 if does not look like number.
1563 * In fact possible values are 0 and
1564 * IS_NUMBER_TO_INT_BY_ATOL 123
1565 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1566 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1567 * with a possible addition of IS_NUMBER_NEG.
1571 Perl_looks_like_number(pTHX_ SV *sv)
1573 /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
1574 * using atof() may lose precision. */
1576 register char *send;
1577 register char *sbegin;
1578 register char *nbegin;
1586 else if (SvPOKp(sv))
1587 sbegin = SvPV(sv, len);
1590 send = sbegin + len;
1597 numtype = IS_NUMBER_NEG;
1604 * we return 1 if the number can be converted to _integer_ with atol()
1605 * and 2 if you need (int)atof().
1608 /* next must be digit or '.' */
1612 } while (isDIGIT(*s));
1614 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1615 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1617 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1621 numtype |= IS_NUMBER_NOT_IV;
1622 while (isDIGIT(*s)) /* optional digits after "." */
1626 else if (*s == '.') {
1628 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1629 /* no digits before '.' means we need digits after it */
1633 } while (isDIGIT(*s));
1641 /* we can have an optional exponent part */
1642 if (*s == 'e' || *s == 'E') {
1643 numtype &= ~IS_NUMBER_NEG;
1644 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1646 if (*s == '+' || *s == '-')
1651 } while (isDIGIT(*s));
1660 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1661 return IS_NUMBER_TO_INT_BY_ATOL;
1666 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1669 return sv_2pv(sv, &n_a);
1672 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1674 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1677 char *ptr = buf + TYPE_CHARS(UV);
1692 *--ptr = '0' + (uv % 10);
1701 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1706 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1707 char *tmpbuf = tbuf;
1713 if (SvGMAGICAL(sv)) {
1719 if (SvIOKp(sv)) { /* XXXX 64-bit? */
1721 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1723 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1728 SET_NUMERIC_STANDARD();
1729 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1734 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1736 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1737 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1743 if (SvTHINKFIRST(sv)) {
1746 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1747 return SvPV(tmpstr,*lp);
1754 switch (SvTYPE(sv)) {
1756 if ( ((SvFLAGS(sv) &
1757 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1758 == (SVs_OBJECT|SVs_RMG))
1759 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1760 && (mg = mg_find(sv, 'r'))) {
1762 regexp *re = (regexp *)mg->mg_obj;
1765 char *fptr = "msix";
1770 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1772 while(ch = *fptr++) {
1774 reflags[left++] = ch;
1777 reflags[right--] = ch;
1782 reflags[left] = '-';
1786 mg->mg_len = re->prelen + 4 + left;
1787 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1788 Copy("(?", mg->mg_ptr, 2, char);
1789 Copy(reflags, mg->mg_ptr+2, left, char);
1790 Copy(":", mg->mg_ptr+left+2, 1, char);
1791 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1792 mg->mg_ptr[mg->mg_len - 1] = ')';
1793 mg->mg_ptr[mg->mg_len] = 0;
1795 PL_reginterp_cnt += re->program[0].next_off;
1807 case SVt_PVBM: s = "SCALAR"; break;
1808 case SVt_PVLV: s = "LVALUE"; break;
1809 case SVt_PVAV: s = "ARRAY"; break;
1810 case SVt_PVHV: s = "HASH"; break;
1811 case SVt_PVCV: s = "CODE"; break;
1812 case SVt_PVGV: s = "GLOB"; break;
1813 case SVt_PVFM: s = "FORMAT"; break;
1814 case SVt_PVIO: s = "IO"; break;
1815 default: s = "UNKNOWN"; break;
1819 sv_setpvf(tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1823 sv_catpvf(tsv, "(0x%lx)", (unsigned long)sv);
1829 if (SvREADONLY(sv)) {
1830 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1831 /* XXXX 64-bit? IV may have better precision... */
1832 SET_NUMERIC_STANDARD();
1833 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1841 tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
1843 tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
1850 if (ckWARN(WARN_UNINITIALIZED))
1851 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1857 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1858 /* XXXX 64-bit? IV may have better precision... */
1859 if (SvTYPE(sv) < SVt_PVNV)
1860 sv_upgrade(sv, SVt_PVNV);
1863 olderrno = errno; /* some Xenix systems wipe out errno here */
1865 if (SvNVX(sv) == 0.0)
1866 (void)strcpy(s,"0");
1870 SET_NUMERIC_STANDARD();
1871 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1874 #ifdef FIXNEGATIVEZERO
1875 if (*s == '-' && s[1] == '0' && !s[2])
1884 else if (SvIOKp(sv)) {
1885 U32 isIOK = SvIOK(sv);
1886 char buf[TYPE_CHARS(UV)];
1889 if (SvTYPE(sv) < SVt_PVIV)
1890 sv_upgrade(sv, SVt_PVIV);
1892 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1893 sv_setpvn(sv, ptr, ebuf - ptr);
1897 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1898 sv_setpvn(sv, ptr, ebuf - ptr);
1908 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1909 warner(WARN_UNINITIALIZED, PL_warn_uninit);
1911 if (SvTYPE(sv) < SVt_PV)
1912 /* Typically the caller expects that sv_any is not NULL now. */
1913 sv_upgrade(sv, SVt_PV);
1916 *lp = s - SvPVX(sv);
1919 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1923 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1924 /* Sneaky stuff here */
1928 tsv = newSVpv(tmpbuf, 0);
1944 len = strlen(tmpbuf);
1946 #ifdef FIXNEGATIVEZERO
1947 if (len == 2 && t[0] == '-' && t[1] == '0') {
1952 (void)SvUPGRADE(sv, SVt_PV);
1954 s = SvGROW(sv, len + 1);
1962 /* This function is only called on magical items */
1964 Perl_sv_2bool(pTHX_ register SV *sv)
1974 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1975 return SvTRUE(tmpsv);
1976 return SvRV(sv) != 0;
1979 register XPV* Xpvtmp;
1980 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1981 (*Xpvtmp->xpv_pv > '0' ||
1982 Xpvtmp->xpv_cur > 1 ||
1983 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
1990 return SvIVX(sv) != 0;
1993 return SvNVX(sv) != 0.0;
2000 /* Note: sv_setsv() should not be called with a source string that needs
2001 * to be reused, since it may destroy the source string if it is marked
2006 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2009 register U32 sflags;
2015 SV_CHECK_THINKFIRST(dstr);
2017 sstr = &PL_sv_undef;
2018 stype = SvTYPE(sstr);
2019 dtype = SvTYPE(dstr);
2023 /* There's a lot of redundancy below but we're going for speed here */
2028 if (dtype != SVt_PVGV) {
2029 (void)SvOK_off(dstr);
2037 sv_upgrade(dstr, SVt_IV);
2040 sv_upgrade(dstr, SVt_PVNV);
2044 sv_upgrade(dstr, SVt_PVIV);
2047 (void)SvIOK_only(dstr);
2048 SvIVX(dstr) = SvIVX(sstr);
2061 sv_upgrade(dstr, SVt_NV);
2066 sv_upgrade(dstr, SVt_PVNV);
2069 SvNVX(dstr) = SvNVX(sstr);
2070 (void)SvNOK_only(dstr);
2078 sv_upgrade(dstr, SVt_RV);
2079 else if (dtype == SVt_PVGV &&
2080 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2083 if (PL_curcop->cop_stash != GvSTASH(dstr))
2084 GvIMPORTED_on(dstr);
2094 sv_upgrade(dstr, SVt_PV);
2097 if (dtype < SVt_PVIV)
2098 sv_upgrade(dstr, SVt_PVIV);
2101 if (dtype < SVt_PVNV)
2102 sv_upgrade(dstr, SVt_PVNV);
2109 croak("Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2110 PL_op_name[PL_op->op_type]);
2112 croak("Bizarre copy of %s", sv_reftype(sstr, 0));
2116 if (dtype <= SVt_PVGV) {
2118 if (dtype != SVt_PVGV) {
2119 char *name = GvNAME(sstr);
2120 STRLEN len = GvNAMELEN(sstr);
2121 sv_upgrade(dstr, SVt_PVGV);
2122 sv_magic(dstr, dstr, '*', name, len);
2123 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2124 GvNAME(dstr) = savepvn(name, len);
2125 GvNAMELEN(dstr) = len;
2126 SvFAKE_on(dstr); /* can coerce to non-glob */
2128 /* ahem, death to those who redefine active sort subs */
2129 else if (PL_curstackinfo->si_type == PERLSI_SORT
2130 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2131 croak("Can't redefine active sort subroutine %s",
2133 (void)SvOK_off(dstr);
2134 GvINTRO_off(dstr); /* one-shot flag */
2136 GvGP(dstr) = gp_ref(GvGP(sstr));
2138 if (PL_curcop->cop_stash != GvSTASH(dstr))
2139 GvIMPORTED_on(dstr);
2146 if (SvGMAGICAL(sstr)) {
2148 if (SvTYPE(sstr) != stype) {
2149 stype = SvTYPE(sstr);
2150 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2154 if (stype == SVt_PVLV)
2155 (void)SvUPGRADE(dstr, SVt_PVNV);
2157 (void)SvUPGRADE(dstr, stype);
2160 sflags = SvFLAGS(sstr);
2162 if (sflags & SVf_ROK) {
2163 if (dtype >= SVt_PV) {
2164 if (dtype == SVt_PVGV) {
2165 SV *sref = SvREFCNT_inc(SvRV(sstr));
2167 int intro = GvINTRO(dstr);
2171 GvGP(dstr)->gp_refcnt--;
2172 GvINTRO_off(dstr); /* one-shot flag */
2173 Newz(602,gp, 1, GP);
2174 GvGP(dstr) = gp_ref(gp);
2175 GvSV(dstr) = NEWSV(72,0);
2176 GvLINE(dstr) = PL_curcop->cop_line;
2177 GvEGV(dstr) = (GV*)dstr;
2180 switch (SvTYPE(sref)) {
2183 SAVESPTR(GvAV(dstr));
2185 dref = (SV*)GvAV(dstr);
2186 GvAV(dstr) = (AV*)sref;
2187 if (PL_curcop->cop_stash != GvSTASH(dstr))
2188 GvIMPORTED_AV_on(dstr);
2192 SAVESPTR(GvHV(dstr));
2194 dref = (SV*)GvHV(dstr);
2195 GvHV(dstr) = (HV*)sref;
2196 if (PL_curcop->cop_stash != GvSTASH(dstr))
2197 GvIMPORTED_HV_on(dstr);
2201 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2202 SvREFCNT_dec(GvCV(dstr));
2203 GvCV(dstr) = Nullcv;
2204 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2205 PL_sub_generation++;
2207 SAVESPTR(GvCV(dstr));
2210 dref = (SV*)GvCV(dstr);
2211 if (GvCV(dstr) != (CV*)sref) {
2212 CV* cv = GvCV(dstr);
2214 if (!GvCVGEN((GV*)dstr) &&
2215 (CvROOT(cv) || CvXSUB(cv)))
2217 SV *const_sv = cv_const_sv(cv);
2218 bool const_changed = TRUE;
2220 const_changed = sv_cmp(const_sv,
2221 op_const_sv(CvSTART((CV*)sref),
2223 /* ahem, death to those who redefine
2224 * active sort subs */
2225 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2226 PL_sortcop == CvSTART(cv))
2228 "Can't redefine active sort subroutine %s",
2229 GvENAME((GV*)dstr));
2230 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2231 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2232 && HvNAME(GvSTASH(CvGV(cv)))
2233 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2235 warner(WARN_REDEFINE, const_sv ?
2236 "Constant subroutine %s redefined"
2237 : "Subroutine %s redefined",
2238 GvENAME((GV*)dstr));
2241 cv_ckproto(cv, (GV*)dstr,
2242 SvPOK(sref) ? SvPVX(sref) : Nullch);
2244 GvCV(dstr) = (CV*)sref;
2245 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2246 GvASSUMECV_on(dstr);
2247 PL_sub_generation++;
2249 if (PL_curcop->cop_stash != GvSTASH(dstr))
2250 GvIMPORTED_CV_on(dstr);
2254 SAVESPTR(GvIOp(dstr));
2256 dref = (SV*)GvIOp(dstr);
2257 GvIOp(dstr) = (IO*)sref;
2261 SAVESPTR(GvSV(dstr));
2263 dref = (SV*)GvSV(dstr);
2265 if (PL_curcop->cop_stash != GvSTASH(dstr))
2266 GvIMPORTED_SV_on(dstr);
2277 (void)SvOOK_off(dstr); /* backoff */
2279 Safefree(SvPVX(dstr));
2280 SvLEN(dstr)=SvCUR(dstr)=0;
2283 (void)SvOK_off(dstr);
2284 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2286 if (sflags & SVp_NOK) {
2288 SvNVX(dstr) = SvNVX(sstr);
2290 if (sflags & SVp_IOK) {
2291 (void)SvIOK_on(dstr);
2292 SvIVX(dstr) = SvIVX(sstr);
2296 if (SvAMAGIC(sstr)) {
2300 else if (sflags & SVp_POK) {
2303 * Check to see if we can just swipe the string. If so, it's a
2304 * possible small lose on short strings, but a big win on long ones.
2305 * It might even be a win on short strings if SvPVX(dstr)
2306 * has to be allocated and SvPVX(sstr) has to be freed.
2309 if (SvTEMP(sstr) && /* slated for free anyway? */
2310 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2311 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2313 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2315 SvFLAGS(dstr) &= ~SVf_OOK;
2316 Safefree(SvPVX(dstr) - SvIVX(dstr));
2318 else if (SvLEN(dstr))
2319 Safefree(SvPVX(dstr));
2321 (void)SvPOK_only(dstr);
2322 SvPV_set(dstr, SvPVX(sstr));
2323 SvLEN_set(dstr, SvLEN(sstr));
2324 SvCUR_set(dstr, SvCUR(sstr));
2326 (void)SvOK_off(sstr);
2327 SvPV_set(sstr, Nullch);
2332 else { /* have to copy actual string */
2333 STRLEN len = SvCUR(sstr);
2335 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2336 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2337 SvCUR_set(dstr, len);
2338 *SvEND(dstr) = '\0';
2339 (void)SvPOK_only(dstr);
2342 if (sflags & SVp_NOK) {
2344 SvNVX(dstr) = SvNVX(sstr);
2346 if (sflags & SVp_IOK) {
2347 (void)SvIOK_on(dstr);
2348 SvIVX(dstr) = SvIVX(sstr);
2353 else if (sflags & SVp_NOK) {
2354 SvNVX(dstr) = SvNVX(sstr);
2355 (void)SvNOK_only(dstr);
2357 (void)SvIOK_on(dstr);
2358 SvIVX(dstr) = SvIVX(sstr);
2359 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2364 else if (sflags & SVp_IOK) {
2365 (void)SvIOK_only(dstr);
2366 SvIVX(dstr) = SvIVX(sstr);
2371 if (dtype == SVt_PVGV) {
2372 if (ckWARN(WARN_UNSAFE))
2373 warner(WARN_UNSAFE, "Undefined value assigned to typeglob");
2376 (void)SvOK_off(dstr);
2382 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2384 sv_setsv(dstr,sstr);
2389 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2391 register char *dptr;
2392 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2393 elicit a warning, but it won't hurt. */
2394 SV_CHECK_THINKFIRST(sv);
2399 (void)SvUPGRADE(sv, SVt_PV);
2401 SvGROW(sv, len + 1);
2403 Move(ptr,dptr,len,char);
2406 (void)SvPOK_only(sv); /* validate pointer */
2411 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2413 sv_setpvn(sv,ptr,len);
2418 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2420 register STRLEN len;
2422 SV_CHECK_THINKFIRST(sv);
2428 (void)SvUPGRADE(sv, SVt_PV);
2430 SvGROW(sv, len + 1);
2431 Move(ptr,SvPVX(sv),len+1,char);
2433 (void)SvPOK_only(sv); /* validate pointer */
2438 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2445 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2447 SV_CHECK_THINKFIRST(sv);
2448 (void)SvUPGRADE(sv, SVt_PV);
2453 (void)SvOOK_off(sv);
2454 if (SvPVX(sv) && SvLEN(sv))
2455 Safefree(SvPVX(sv));
2456 Renew(ptr, len+1, char);
2459 SvLEN_set(sv, len+1);
2461 (void)SvPOK_only(sv); /* validate pointer */
2466 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2468 sv_usepvn(sv,ptr,len);
2473 Perl_sv_force_normal(pTHX_ register SV *sv)
2475 if (SvREADONLY(sv)) {
2477 if (PL_curcop != &PL_compiling)
2478 croak(PL_no_modify);
2482 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2487 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2491 register STRLEN delta;
2493 if (!ptr || !SvPOKp(sv))
2495 SV_CHECK_THINKFIRST(sv);
2496 if (SvTYPE(sv) < SVt_PVIV)
2497 sv_upgrade(sv,SVt_PVIV);
2500 if (!SvLEN(sv)) { /* make copy of shared string */
2501 char *pvx = SvPVX(sv);
2502 STRLEN len = SvCUR(sv);
2503 SvGROW(sv, len + 1);
2504 Move(pvx,SvPVX(sv),len,char);
2508 SvFLAGS(sv) |= SVf_OOK;
2510 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2511 delta = ptr - SvPVX(sv);
2519 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2524 junk = SvPV_force(sv, tlen);
2525 SvGROW(sv, tlen + len + 1);
2528 Move(ptr,SvPVX(sv)+tlen,len,char);
2531 (void)SvPOK_only(sv); /* validate pointer */
2536 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2538 sv_catpvn(sv,ptr,len);
2543 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2549 if (s = SvPV(sstr, len))
2550 sv_catpvn(dstr,s,len);
2554 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2556 sv_catsv(dstr,sstr);
2561 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2563 register STRLEN len;
2569 junk = SvPV_force(sv, tlen);
2571 SvGROW(sv, tlen + len + 1);
2574 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2576 (void)SvPOK_only(sv); /* validate pointer */
2581 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2588 Perl_newSV(pTHX_ STRLEN len)
2594 sv_upgrade(sv, SVt_PV);
2595 SvGROW(sv, len + 1);
2600 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2603 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2607 if (SvREADONLY(sv)) {
2609 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2610 croak(PL_no_modify);
2612 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2613 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2620 (void)SvUPGRADE(sv, SVt_PVMG);
2622 Newz(702,mg, 1, MAGIC);
2623 mg->mg_moremagic = SvMAGIC(sv);
2626 if (!obj || obj == sv || how == '#' || how == 'r')
2630 mg->mg_obj = SvREFCNT_inc(obj);
2631 mg->mg_flags |= MGf_REFCOUNTED;
2634 mg->mg_len = namlen;
2637 mg->mg_ptr = savepvn(name, namlen);
2638 else if (namlen == HEf_SVKEY)
2639 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2643 mg->mg_virtual = &PL_vtbl_sv;
2646 mg->mg_virtual = &PL_vtbl_amagic;
2649 mg->mg_virtual = &PL_vtbl_amagicelem;
2655 mg->mg_virtual = &PL_vtbl_bm;
2658 mg->mg_virtual = &PL_vtbl_regdata;
2661 mg->mg_virtual = &PL_vtbl_regdatum;
2664 mg->mg_virtual = &PL_vtbl_env;
2667 mg->mg_virtual = &PL_vtbl_fm;
2670 mg->mg_virtual = &PL_vtbl_envelem;
2673 mg->mg_virtual = &PL_vtbl_mglob;
2676 mg->mg_virtual = &PL_vtbl_isa;
2679 mg->mg_virtual = &PL_vtbl_isaelem;
2682 mg->mg_virtual = &PL_vtbl_nkeys;
2689 mg->mg_virtual = &PL_vtbl_dbline;
2693 mg->mg_virtual = &PL_vtbl_mutex;
2695 #endif /* USE_THREADS */
2696 #ifdef USE_LOCALE_COLLATE
2698 mg->mg_virtual = &PL_vtbl_collxfrm;
2700 #endif /* USE_LOCALE_COLLATE */
2702 mg->mg_virtual = &PL_vtbl_pack;
2706 mg->mg_virtual = &PL_vtbl_packelem;
2709 mg->mg_virtual = &PL_vtbl_regexp;
2712 mg->mg_virtual = &PL_vtbl_sig;
2715 mg->mg_virtual = &PL_vtbl_sigelem;
2718 mg->mg_virtual = &PL_vtbl_taint;
2722 mg->mg_virtual = &PL_vtbl_uvar;
2725 mg->mg_virtual = &PL_vtbl_vec;
2728 mg->mg_virtual = &PL_vtbl_substr;
2731 mg->mg_virtual = &PL_vtbl_defelem;
2734 mg->mg_virtual = &PL_vtbl_glob;
2737 mg->mg_virtual = &PL_vtbl_arylen;
2740 mg->mg_virtual = &PL_vtbl_pos;
2743 mg->mg_virtual = &PL_vtbl_backref;
2745 case '~': /* Reserved for use by extensions not perl internals. */
2746 /* Useful for attaching extension internal data to perl vars. */
2747 /* Note that multiple extensions may clash if magical scalars */
2748 /* etc holding private data from one are passed to another. */
2752 croak("Don't know how to handle magic of type '%c'", how);
2756 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2760 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2764 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2767 for (mg = *mgp; mg; mg = *mgp) {
2768 if (mg->mg_type == type) {
2769 MGVTBL* vtbl = mg->mg_virtual;
2770 *mgp = mg->mg_moremagic;
2771 if (vtbl && (vtbl->svt_free != NULL))
2772 (VTBL->svt_free)(sv, mg);
2773 if (mg->mg_ptr && mg->mg_type != 'g')
2774 if (mg->mg_len >= 0)
2775 Safefree(mg->mg_ptr);
2776 else if (mg->mg_len == HEf_SVKEY)
2777 SvREFCNT_dec((SV*)mg->mg_ptr);
2778 if (mg->mg_flags & MGf_REFCOUNTED)
2779 SvREFCNT_dec(mg->mg_obj);
2783 mgp = &mg->mg_moremagic;
2787 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2794 Perl_sv_rvweaken(pTHX_ SV *sv)
2797 if (!SvOK(sv)) /* let undefs pass */
2800 croak("Can't weaken a nonreference");
2801 else if (SvWEAKREF(sv)) {
2803 if (ckWARN(WARN_MISC))
2804 warner(WARN_MISC, "Reference is already weak");
2808 sv_add_backref(tsv, sv);
2815 sv_add_backref(pTHX_ SV *tsv, SV *sv)
2819 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2820 av = (AV*)mg->mg_obj;
2823 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2824 SvREFCNT_dec(av); /* for sv_magic */
2830 sv_del_backref(pTHX_ SV *sv)
2837 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2838 croak("panic: del_backref");
2839 av = (AV *)mg->mg_obj;
2844 svp[i] = &PL_sv_undef; /* XXX */
2851 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2855 register char *midend;
2856 register char *bigend;
2862 croak("Can't modify non-existent substring");
2863 SvPV_force(bigstr, curlen);
2864 if (offset + len > curlen) {
2865 SvGROW(bigstr, offset+len+1);
2866 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2867 SvCUR_set(bigstr, offset+len);
2870 i = littlelen - len;
2871 if (i > 0) { /* string might grow */
2872 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2873 mid = big + offset + len;
2874 midend = bigend = big + SvCUR(bigstr);
2877 while (midend > mid) /* shove everything down */
2878 *--bigend = *--midend;
2879 Move(little,big+offset,littlelen,char);
2885 Move(little,SvPVX(bigstr)+offset,len,char);
2890 big = SvPVX(bigstr);
2893 bigend = big + SvCUR(bigstr);
2895 if (midend > bigend)
2896 croak("panic: sv_insert");
2898 if (mid - big > bigend - midend) { /* faster to shorten from end */
2900 Move(little, mid, littlelen,char);
2903 i = bigend - midend;
2905 Move(midend, mid, i,char);
2909 SvCUR_set(bigstr, mid - big);
2912 else if (i = mid - big) { /* faster from front */
2913 midend -= littlelen;
2915 sv_chop(bigstr,midend-i);
2920 Move(little, mid, littlelen,char);
2922 else if (littlelen) {
2923 midend -= littlelen;
2924 sv_chop(bigstr,midend);
2925 Move(little,midend,littlelen,char);
2928 sv_chop(bigstr,midend);
2933 /* make sv point to what nstr did */
2936 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2938 U32 refcnt = SvREFCNT(sv);
2939 SV_CHECK_THINKFIRST(sv);
2940 if (SvREFCNT(nsv) != 1)
2941 warn("Reference miscount in sv_replace()");
2942 if (SvMAGICAL(sv)) {
2946 sv_upgrade(nsv, SVt_PVMG);
2947 SvMAGIC(nsv) = SvMAGIC(sv);
2948 SvFLAGS(nsv) |= SvMAGICAL(sv);
2954 assert(!SvREFCNT(sv));
2955 StructCopy(nsv,sv,SV);
2956 SvREFCNT(sv) = refcnt;
2957 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2962 Perl_sv_clear(pTHX_ register SV *sv)
2966 assert(SvREFCNT(sv) == 0);
2970 if (PL_defstash) { /* Still have a symbol table? */
2975 Zero(&tmpref, 1, SV);
2976 sv_upgrade(&tmpref, SVt_RV);
2978 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
2979 SvREFCNT(&tmpref) = 1;
2982 stash = SvSTASH(sv);
2983 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2986 PUSHSTACKi(PERLSI_DESTROY);
2987 SvRV(&tmpref) = SvREFCNT_inc(sv);
2992 call_sv((SV*)GvCV(destructor),
2993 G_DISCARD|G_EVAL|G_KEEPERR);
2999 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3001 del_XRV(SvANY(&tmpref));
3004 if (PL_in_clean_objs)
3005 croak("DESTROY created new reference to dead object '%s'",
3007 /* DESTROY gave object new lease on life */
3013 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3014 SvOBJECT_off(sv); /* Curse the object. */
3015 if (SvTYPE(sv) != SVt_PVIO)
3016 --PL_sv_objcount; /* XXX Might want something more general */
3019 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3022 switch (SvTYPE(sv)) {
3025 IoIFP(sv) != PerlIO_stdin() &&
3026 IoIFP(sv) != PerlIO_stdout() &&
3027 IoIFP(sv) != PerlIO_stderr())
3032 PerlDir_close(IoDIRP(sv));
3035 Safefree(IoTOP_NAME(sv));
3036 Safefree(IoFMT_NAME(sv));
3037 Safefree(IoBOTTOM_NAME(sv));
3052 SvREFCNT_dec(LvTARG(sv));
3056 Safefree(GvNAME(sv));
3057 /* cannot decrease stash refcount yet, as we might recursively delete
3058 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3059 of stash until current sv is completely gone.
3060 -- JohnPC, 27 Mar 1998 */
3061 stash = GvSTASH(sv);
3067 (void)SvOOK_off(sv);
3075 SvREFCNT_dec(SvRV(sv));
3077 else if (SvPVX(sv) && SvLEN(sv))
3078 Safefree(SvPVX(sv));
3088 switch (SvTYPE(sv)) {
3104 del_XPVIV(SvANY(sv));
3107 del_XPVNV(SvANY(sv));
3110 del_XPVMG(SvANY(sv));
3113 del_XPVLV(SvANY(sv));
3116 del_XPVAV(SvANY(sv));
3119 del_XPVHV(SvANY(sv));
3122 del_XPVCV(SvANY(sv));
3125 del_XPVGV(SvANY(sv));
3126 /* code duplication for increased performance. */
3127 SvFLAGS(sv) &= SVf_BREAK;
3128 SvFLAGS(sv) |= SVTYPEMASK;
3129 /* decrease refcount of the stash that owns this GV, if any */
3131 SvREFCNT_dec(stash);
3132 return; /* not break, SvFLAGS reset already happened */
3134 del_XPVBM(SvANY(sv));
3137 del_XPVFM(SvANY(sv));
3140 del_XPVIO(SvANY(sv));
3143 SvFLAGS(sv) &= SVf_BREAK;
3144 SvFLAGS(sv) |= SVTYPEMASK;
3148 Perl_sv_newref(pTHX_ SV *sv)
3151 ATOMIC_INC(SvREFCNT(sv));
3156 Perl_sv_free(pTHX_ SV *sv)
3158 int refcount_is_zero;
3162 if (SvREFCNT(sv) == 0) {
3163 if (SvFLAGS(sv) & SVf_BREAK)
3165 if (PL_in_clean_all) /* All is fair */
3167 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3168 /* make sure SvREFCNT(sv)==0 happens very seldom */
3169 SvREFCNT(sv) = (~(U32)0)/2;
3172 warn("Attempt to free unreferenced scalar");
3175 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3176 if (!refcount_is_zero)
3180 warn("Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3184 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3185 /* make sure SvREFCNT(sv)==0 happens very seldom */
3186 SvREFCNT(sv) = (~(U32)0)/2;
3195 Perl_sv_len(pTHX_ register SV *sv)
3204 len = mg_length(sv);
3206 junk = SvPV(sv, len);
3211 Perl_sv_len_utf8(pTHX_ register SV *sv)
3222 len = mg_length(sv);
3225 s = (U8*)SvPV(sv, len);
3236 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3241 I32 uoffset = *offsetp;
3247 start = s = (U8*)SvPV(sv, len);
3249 while (s < send && uoffset--)
3253 *offsetp = s - start;
3257 while (s < send && ulen--)
3267 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3276 s = (U8*)SvPV(sv, len);
3278 croak("panic: bad byte offset");
3279 send = s + *offsetp;
3286 warn("Malformed UTF-8 character");
3294 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3306 pv1 = SvPV(str1, cur1);
3311 pv2 = SvPV(str2, cur2);
3316 return memEQ(pv1, pv2, cur1);
3320 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3323 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3325 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3329 return cur2 ? -1 : 0;
3334 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3337 return retval < 0 ? -1 : 1;
3342 return cur1 < cur2 ? -1 : 1;
3346 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3348 #ifdef USE_LOCALE_COLLATE
3354 if (PL_collation_standard)
3358 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3360 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3362 if (!pv1 || !len1) {
3373 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3376 return retval < 0 ? -1 : 1;
3379 * When the result of collation is equality, that doesn't mean
3380 * that there are no differences -- some locales exclude some
3381 * characters from consideration. So to avoid false equalities,
3382 * we use the raw string as a tiebreaker.
3388 #endif /* USE_LOCALE_COLLATE */
3390 return sv_cmp(sv1, sv2);
3393 #ifdef USE_LOCALE_COLLATE
3395 * Any scalar variable may carry an 'o' magic that contains the
3396 * scalar data of the variable transformed to such a format that
3397 * a normal memory comparison can be used to compare the data
3398 * according to the locale settings.
3401 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3405 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3406 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3411 Safefree(mg->mg_ptr);
3413 if ((xf = mem_collxfrm(s, len, &xlen))) {
3414 if (SvREADONLY(sv)) {
3417 return xf + sizeof(PL_collation_ix);
3420 sv_magic(sv, 0, 'o', 0, 0);
3421 mg = mg_find(sv, 'o');
3434 if (mg && mg->mg_ptr) {
3436 return mg->mg_ptr + sizeof(PL_collation_ix);
3444 #endif /* USE_LOCALE_COLLATE */
3447 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3452 register STDCHAR rslast;
3453 register STDCHAR *bp;
3457 SV_CHECK_THINKFIRST(sv);
3458 (void)SvUPGRADE(sv, SVt_PV);
3462 if (RsSNARF(PL_rs)) {
3466 else if (RsRECORD(PL_rs)) {
3467 I32 recsize, bytesread;
3470 /* Grab the size of the record we're getting */
3471 recsize = SvIV(SvRV(PL_rs));
3472 (void)SvPOK_only(sv); /* Validate pointer */
3473 buffer = SvGROW(sv, recsize + 1);
3476 /* VMS wants read instead of fread, because fread doesn't respect */
3477 /* RMS record boundaries. This is not necessarily a good thing to be */
3478 /* doing, but we've got no other real choice */
3479 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3481 bytesread = PerlIO_read(fp, buffer, recsize);
3483 SvCUR_set(sv, bytesread);
3484 buffer[bytesread] = '\0';
3485 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3487 else if (RsPARA(PL_rs)) {
3492 rsptr = SvPV(PL_rs, rslen);
3493 rslast = rslen ? rsptr[rslen - 1] : '\0';
3495 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3496 do { /* to make sure file boundaries work right */
3499 i = PerlIO_getc(fp);
3503 PerlIO_ungetc(fp,i);
3509 /* See if we know enough about I/O mechanism to cheat it ! */
3511 /* This used to be #ifdef test - it is made run-time test for ease
3512 of abstracting out stdio interface. One call should be cheap
3513 enough here - and may even be a macro allowing compile
3517 if (PerlIO_fast_gets(fp)) {
3520 * We're going to steal some values from the stdio struct
3521 * and put EVERYTHING in the innermost loop into registers.
3523 register STDCHAR *ptr;
3527 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3528 /* An ungetc()d char is handled separately from the regular
3529 * buffer, so we getc() it back out and stuff it in the buffer.
3531 i = PerlIO_getc(fp);
3532 if (i == EOF) return 0;
3533 *(--((*fp)->_ptr)) = (unsigned char) i;
3537 /* Here is some breathtakingly efficient cheating */
3539 cnt = PerlIO_get_cnt(fp); /* get count into register */
3540 (void)SvPOK_only(sv); /* validate pointer */
3541 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3542 if (cnt > 80 && SvLEN(sv) > append) {
3543 shortbuffered = cnt - SvLEN(sv) + append + 1;
3544 cnt -= shortbuffered;
3548 /* remember that cnt can be negative */
3549 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3554 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3555 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3556 DEBUG_P(PerlIO_printf(Perl_debug_log,
3557 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3558 DEBUG_P(PerlIO_printf(Perl_debug_log,
3559 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3560 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3561 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3566 while (cnt > 0) { /* this | eat */
3568 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3569 goto thats_all_folks; /* screams | sed :-) */
3573 Copy(ptr, bp, cnt, char); /* this | eat */
3574 bp += cnt; /* screams | dust */
3575 ptr += cnt; /* louder | sed :-) */
3580 if (shortbuffered) { /* oh well, must extend */
3581 cnt = shortbuffered;
3583 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3585 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3586 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3590 DEBUG_P(PerlIO_printf(Perl_debug_log,
3591 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3592 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3593 DEBUG_P(PerlIO_printf(Perl_debug_log,
3594 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3595 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3596 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3597 /* This used to call 'filbuf' in stdio form, but as that behaves like
3598 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3599 another abstraction. */
3600 i = PerlIO_getc(fp); /* get more characters */
3601 DEBUG_P(PerlIO_printf(Perl_debug_log,
3602 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3603 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3604 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3605 cnt = PerlIO_get_cnt(fp);
3606 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3607 DEBUG_P(PerlIO_printf(Perl_debug_log,
3608 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3610 if (i == EOF) /* all done for ever? */
3611 goto thats_really_all_folks;
3613 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3615 SvGROW(sv, bpx + cnt + 2);
3616 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3618 *bp++ = i; /* store character from PerlIO_getc */
3620 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3621 goto thats_all_folks;
3625 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3626 memNE((char*)bp - rslen, rsptr, rslen))
3627 goto screamer; /* go back to the fray */
3628 thats_really_all_folks:
3630 cnt += shortbuffered;
3631 DEBUG_P(PerlIO_printf(Perl_debug_log,
3632 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3633 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3634 DEBUG_P(PerlIO_printf(Perl_debug_log,
3635 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3636 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3637 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3639 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3640 DEBUG_P(PerlIO_printf(Perl_debug_log,
3641 "Screamer: done, len=%ld, string=|%.*s|\n",
3642 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3646 /*The big, slow, and stupid way */
3651 register STDCHAR *bpe = buf + sizeof(buf);
3653 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3654 ; /* keep reading */
3658 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3659 /* Accomodate broken VAXC compiler, which applies U8 cast to
3660 * both args of ?: operator, causing EOF to change into 255
3662 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3666 sv_catpvn(sv, (char *) buf, cnt);
3668 sv_setpvn(sv, (char *) buf, cnt);
3670 if (i != EOF && /* joy */
3672 SvCUR(sv) < rslen ||
3673 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3677 * If we're reading from a TTY and we get a short read,
3678 * indicating that the user hit his EOF character, we need
3679 * to notice it now, because if we try to read from the TTY
3680 * again, the EOF condition will disappear.
3682 * The comparison of cnt to sizeof(buf) is an optimization
3683 * that prevents unnecessary calls to feof().
3687 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3692 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3693 while (i != EOF) { /* to make sure file boundaries work right */
3694 i = PerlIO_getc(fp);
3696 PerlIO_ungetc(fp,i);
3703 win32_strip_return(sv);
3706 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3711 Perl_sv_inc(pTHX_ register SV *sv)
3720 if (SvTHINKFIRST(sv)) {
3721 if (SvREADONLY(sv)) {
3723 if (PL_curcop != &PL_compiling)
3724 croak(PL_no_modify);
3728 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3735 flags = SvFLAGS(sv);
3736 if (flags & SVp_NOK) {
3737 (void)SvNOK_only(sv);
3741 if (flags & SVp_IOK) {
3743 if (SvUVX(sv) == UV_MAX)
3744 sv_setnv(sv, (double)UV_MAX + 1.0);
3746 (void)SvIOK_only_UV(sv);
3749 if (SvIVX(sv) == IV_MAX)
3750 sv_setnv(sv, (double)IV_MAX + 1.0);
3752 (void)SvIOK_only(sv);
3758 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3759 if ((flags & SVTYPEMASK) < SVt_PVNV)
3760 sv_upgrade(sv, SVt_NV);
3762 (void)SvNOK_only(sv);
3766 while (isALPHA(*d)) d++;
3767 while (isDIGIT(*d)) d++;
3769 SET_NUMERIC_STANDARD();
3770 sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
3774 while (d >= SvPVX(sv)) {
3782 /* MKS: The original code here died if letters weren't consecutive.
3783 * at least it didn't have to worry about non-C locales. The
3784 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3785 * arranged in order (although not consecutively) and that only
3786 * [A-Za-z] are accepted by isALPHA in the C locale.
3788 if (*d != 'z' && *d != 'Z') {
3789 do { ++*d; } while (!isALPHA(*d));
3792 *(d--) -= 'z' - 'a';
3797 *(d--) -= 'z' - 'a' + 1;
3801 /* oh,oh, the number grew */
3802 SvGROW(sv, SvCUR(sv) + 2);
3804 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3813 Perl_sv_dec(pTHX_ register SV *sv)
3821 if (SvTHINKFIRST(sv)) {
3822 if (SvREADONLY(sv)) {
3824 if (PL_curcop != &PL_compiling)
3825 croak(PL_no_modify);
3829 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3836 flags = SvFLAGS(sv);
3837 if (flags & SVp_NOK) {
3839 (void)SvNOK_only(sv);
3842 if (flags & SVp_IOK) {
3844 if (SvUVX(sv) == 0) {
3845 (void)SvIOK_only(sv);
3849 (void)SvIOK_only_UV(sv);
3853 if (SvIVX(sv) == IV_MIN)
3854 sv_setnv(sv, (double)IV_MIN - 1.0);
3856 (void)SvIOK_only(sv);
3862 if (!(flags & SVp_POK)) {
3863 if ((flags & SVTYPEMASK) < SVt_PVNV)
3864 sv_upgrade(sv, SVt_NV);
3866 (void)SvNOK_only(sv);
3869 SET_NUMERIC_STANDARD();
3870 sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
3873 /* Make a string that will exist for the duration of the expression
3874 * evaluation. Actually, it may have to last longer than that, but
3875 * hopefully we won't free it until it has been assigned to a
3876 * permanent location. */
3879 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3885 sv_setsv(sv,oldstr);
3887 PL_tmps_stack[++PL_tmps_ix] = sv;
3893 Perl_sv_newmortal(pTHX)
3899 SvFLAGS(sv) = SVs_TEMP;
3901 PL_tmps_stack[++PL_tmps_ix] = sv;
3905 /* same thing without the copying */
3908 Perl_sv_2mortal(pTHX_ register SV *sv)
3913 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3916 PL_tmps_stack[++PL_tmps_ix] = sv;
3922 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3929 sv_setpvn(sv,s,len);
3934 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3939 sv_setpvn(sv,s,len);
3944 Perl_newSVpvf(pTHX_ const char* pat, ...)
3950 va_start(args, pat);
3951 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3958 Perl_newSVnv(pTHX_ double n)
3968 Perl_newSViv(pTHX_ IV i)
3978 Perl_newRV_noinc(pTHX_ SV *tmpRef)
3984 sv_upgrade(sv, SVt_RV);
3992 Perl_newRV(pTHX_ SV *tmpRef)
3994 return newRV_noinc(SvREFCNT_inc(tmpRef));
3997 /* make an exact duplicate of old */
4000 Perl_newSVsv(pTHX_ register SV *old)
4006 if (SvTYPE(old) == SVTYPEMASK) {
4007 warn("semi-panic: attempt to dup freed string");
4022 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4035 if (!*s) { /* reset ?? searches */
4036 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4037 pm->op_pmdynflags &= ~PMdf_USED;
4042 /* reset variables */
4044 if (!HvARRAY(stash))
4047 Zero(todo, 256, char);
4054 for ( ; i <= max; i++) {
4057 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4058 for (entry = HvARRAY(stash)[i];
4060 entry = HeNEXT(entry))
4062 if (!todo[(U8)*HeKEY(entry)])
4064 gv = (GV*)HeVAL(entry);
4066 if (SvTHINKFIRST(sv)) {
4067 if (!SvREADONLY(sv) && SvROK(sv))
4072 if (SvTYPE(sv) >= SVt_PV) {
4074 if (SvPVX(sv) != Nullch)
4081 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4083 #ifndef VMS /* VMS has no environ array */
4085 environ[0] = Nullch;
4094 Perl_sv_2io(pTHX_ SV *sv)
4100 switch (SvTYPE(sv)) {
4108 croak("Bad filehandle: %s", GvNAME(gv));
4112 croak(PL_no_usym, "filehandle");
4114 return sv_2io(SvRV(sv));
4115 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4121 croak("Bad filehandle: %s", SvPV(sv,n_a));
4128 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4135 return *gvp = Nullgv, Nullcv;
4136 switch (SvTYPE(sv)) {
4156 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4157 tryAMAGICunDEREF(to_cv);
4160 if (SvTYPE(sv) == SVt_PVCV) {
4169 croak("Not a subroutine reference");
4174 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4180 if (lref && !GvCVu(gv)) {
4183 tmpsv = NEWSV(704,0);
4184 gv_efullname3(tmpsv, gv, Nullch);
4185 /* XXX this is probably not what they think they're getting.
4186 * It has the same effect as "sub name;", i.e. just a forward
4188 newSUB(start_subparse(FALSE, 0),
4189 newSVOP(OP_CONST, 0, tmpsv),
4194 croak("Unable to create sub named \"%s\"", SvPV(sv,n_a));
4201 Perl_sv_true(pTHX_ register SV *sv)
4208 if ((tXpv = (XPV*)SvANY(sv)) &&
4209 (*tXpv->xpv_pv > '0' ||
4210 tXpv->xpv_cur > 1 ||
4211 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4218 return SvIVX(sv) != 0;
4221 return SvNVX(sv) != 0.0;
4223 return sv_2bool(sv);
4229 Perl_sv_iv(pTHX_ register SV *sv)
4233 return (IV)SvUVX(sv);
4240 Perl_sv_uv(pTHX_ register SV *sv)
4245 return (UV)SvIVX(sv);
4251 Perl_sv_nv(pTHX_ register SV *sv)
4259 Perl_sv_pv(pTHX_ SV *sv)
4266 return sv_2pv(sv, &n_a);
4270 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4276 return sv_2pv(sv, lp);
4280 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4284 if (SvTHINKFIRST(sv) && !SvROK(sv))
4285 sv_force_normal(sv);
4291 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4293 croak("Can't coerce %s to string in %s", sv_reftype(sv,0),
4294 PL_op_name[PL_op->op_type]);
4298 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4303 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4304 SvGROW(sv, len + 1);
4305 Move(s,SvPVX(sv),len,char);
4310 SvPOK_on(sv); /* validate pointer */
4312 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4313 (unsigned long)sv,SvPVX(sv)));
4320 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4322 if (ob && SvOBJECT(sv))
4323 return HvNAME(SvSTASH(sv));
4325 switch (SvTYPE(sv)) {
4339 case SVt_PVLV: return "LVALUE";
4340 case SVt_PVAV: return "ARRAY";
4341 case SVt_PVHV: return "HASH";
4342 case SVt_PVCV: return "CODE";
4343 case SVt_PVGV: return "GLOB";
4344 case SVt_PVFM: return "FORMAT";
4345 default: return "UNKNOWN";
4351 Perl_sv_isobject(pTHX_ SV *sv)
4366 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4378 return strEQ(HvNAME(SvSTASH(sv)), name);
4382 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4389 SV_CHECK_THINKFIRST(rv);
4392 if (SvTYPE(rv) < SVt_RV)
4393 sv_upgrade(rv, SVt_RV);
4400 HV* stash = gv_stashpv(classname, TRUE);
4401 (void)sv_bless(rv, stash);
4407 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4410 sv_setsv(rv, &PL_sv_undef);
4414 sv_setiv(newSVrv(rv,classname), (IV)pv);
4419 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4421 sv_setiv(newSVrv(rv,classname), iv);
4426 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, double nv)
4428 sv_setnv(newSVrv(rv,classname), nv);
4433 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4435 sv_setpvn(newSVrv(rv,classname), pv, n);
4440 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4445 croak("Can't bless non-reference value");
4447 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4448 if (SvREADONLY(tmpRef))
4449 croak(PL_no_modify);
4450 if (SvOBJECT(tmpRef)) {
4451 if (SvTYPE(tmpRef) != SVt_PVIO)
4453 SvREFCNT_dec(SvSTASH(tmpRef));
4456 SvOBJECT_on(tmpRef);
4457 if (SvTYPE(tmpRef) != SVt_PVIO)
4459 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4460 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4471 sv_unglob(pTHX_ SV *sv)
4473 assert(SvTYPE(sv) == SVt_PVGV);
4478 SvREFCNT_dec(GvSTASH(sv));
4479 GvSTASH(sv) = Nullhv;
4481 sv_unmagic(sv, '*');
4482 Safefree(GvNAME(sv));
4484 SvFLAGS(sv) &= ~SVTYPEMASK;
4485 SvFLAGS(sv) |= SVt_PVMG;
4489 Perl_sv_unref(pTHX_ SV *sv)
4493 if (SvWEAKREF(sv)) {
4501 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4504 sv_2mortal(rv); /* Schedule for freeing later */
4508 Perl_sv_taint(pTHX_ SV *sv)
4510 sv_magic((sv), Nullsv, 't', Nullch, 0);
4514 Perl_sv_untaint(pTHX_ SV *sv)
4516 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4517 MAGIC *mg = mg_find(sv, 't');
4524 Perl_sv_tainted(pTHX_ SV *sv)
4526 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4527 MAGIC *mg = mg_find(sv, 't');
4528 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4535 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4537 char buf[TYPE_CHARS(UV)];
4539 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4541 sv_setpvn(sv, ptr, ebuf - ptr);
4546 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4548 char buf[TYPE_CHARS(UV)];
4550 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4552 sv_setpvn(sv, ptr, ebuf - ptr);
4557 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4560 va_start(args, pat);
4561 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4567 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4570 va_start(args, pat);
4571 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4577 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4580 va_start(args, pat);
4581 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4586 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4589 va_start(args, pat);
4590 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4596 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4598 sv_setpvn(sv, "", 0);
4599 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4603 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4611 static char nullstr[] = "(null)";
4613 /* no matter what, this is a string now */
4614 (void)SvPV_force(sv, origlen);
4616 /* special-case "", "%s", and "%_" */
4619 if (patlen == 2 && pat[0] == '%') {
4623 char *s = va_arg(*args, char*);
4624 sv_catpv(sv, s ? s : nullstr);
4626 else if (svix < svmax)
4627 sv_catsv(sv, *svargs);
4631 sv_catsv(sv, va_arg(*args, SV*));
4634 /* See comment on '_' below */
4639 patend = (char*)pat + patlen;
4640 for (p = (char*)pat; p < patend; p = q) {
4648 bool has_precis = FALSE;
4653 STRLEN esignlen = 0;
4655 char *eptr = Nullch;
4657 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4668 for (q = p; q < patend && *q != '%'; ++q) ;
4670 sv_catpvn(sv, p, q - p);
4708 case '1': case '2': case '3':
4709 case '4': case '5': case '6':
4710 case '7': case '8': case '9':
4713 width = width * 10 + (*q++ - '0');
4718 i = va_arg(*args, int);
4720 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4722 width = (i < 0) ? -i : i;
4733 i = va_arg(*args, int);
4735 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4736 precis = (i < 0) ? 0 : i;
4742 precis = precis * 10 + (*q++ - '0');
4751 #if 0 /* when quads have better support within Perl */
4752 if (*(q + 1) == 'l') {
4779 uv = va_arg(*args, int);
4781 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4783 eptr = (char*)utf8buf;
4784 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4788 c = va_arg(*args, int);
4790 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4797 eptr = va_arg(*args, char*);
4799 elen = strlen(eptr);
4802 elen = sizeof nullstr - 1;
4805 else if (svix < svmax) {
4806 eptr = SvPVx(svargs[svix++], elen);
4808 if (has_precis && precis < elen) {
4810 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4813 if (width) { /* fudge width (can't fudge elen) */
4814 width += elen - sv_len_utf8(svargs[svix - 1]);
4822 * The "%_" hack might have to be changed someday,
4823 * if ISO or ANSI decide to use '_' for something.
4824 * So we keep it hidden from users' code.
4828 eptr = SvPVx(va_arg(*args, SV*), elen);
4831 if (has_precis && elen > precis)
4839 uv = (UV)va_arg(*args, void*);
4841 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4852 case 'h': iv = (short)va_arg(*args, int); break;
4853 default: iv = va_arg(*args, int); break;
4854 case 'l': iv = va_arg(*args, long); break;
4855 case 'V': iv = va_arg(*args, IV); break;
4859 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4861 case 'h': iv = (short)iv; break;
4862 default: iv = (int)iv; break;
4863 case 'l': iv = (long)iv; break;
4870 esignbuf[esignlen++] = plus;
4874 esignbuf[esignlen++] = '-';
4904 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4905 default: uv = va_arg(*args, unsigned); break;
4906 case 'l': uv = va_arg(*args, unsigned long); break;
4907 case 'V': uv = va_arg(*args, UV); break;
4911 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4913 case 'h': uv = (unsigned short)uv; break;
4914 default: uv = (unsigned)uv; break;
4915 case 'l': uv = (unsigned long)uv; break;
4921 eptr = ebuf + sizeof ebuf;
4927 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
4933 esignbuf[esignlen++] = '0';
4934 esignbuf[esignlen++] = c; /* 'x' or 'X' */
4940 *--eptr = '0' + dig;
4942 if (alt && *eptr != '0')
4948 *--eptr = '0' + dig;
4950 if (alt && *eptr != '0')
4953 default: /* it had better be ten or less */
4956 *--eptr = '0' + dig;
4957 } while (uv /= base);
4960 elen = (ebuf + sizeof ebuf) - eptr;
4963 zeros = precis - elen;
4964 else if (precis == 0 && elen == 1 && *eptr == '0')
4969 /* FLOATING POINT */
4972 c = 'f'; /* maybe %F isn't supported here */
4978 /* This is evil, but floating point is even more evil */
4981 nv = va_arg(*args, double);
4983 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
4986 if (c != 'e' && c != 'E') {
4988 (void)frexp(nv, &i);
4989 if (i == PERL_INT_MIN)
4990 die("panic: frexp");
4992 need = BIT_DIGITS(i);
4994 need += has_precis ? precis : 6; /* known default */
4998 need += 20; /* fudge factor */
4999 if (PL_efloatsize < need) {
5000 Safefree(PL_efloatbuf);
5001 PL_efloatsize = need + 20; /* more fudge */
5002 New(906, PL_efloatbuf, PL_efloatsize, char);
5005 eptr = ebuf + sizeof ebuf;
5010 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5015 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5027 (void)sprintf(PL_efloatbuf, eptr, nv);
5029 eptr = PL_efloatbuf;
5030 elen = strlen(PL_efloatbuf);
5034 * User-defined locales may include arbitrary characters.
5035 * And, unfortunately, some system may alloc the "C" locale
5036 * to be overridden by a malicious user.
5039 *used_locale = TRUE;
5040 #endif /* LC_NUMERIC */
5047 i = SvCUR(sv) - origlen;
5050 case 'h': *(va_arg(*args, short*)) = i; break;
5051 default: *(va_arg(*args, int*)) = i; break;
5052 case 'l': *(va_arg(*args, long*)) = i; break;
5053 case 'V': *(va_arg(*args, IV*)) = i; break;
5056 else if (svix < svmax)
5057 sv_setuv(svargs[svix++], (UV)i);
5058 continue; /* not "break" */
5064 if (!args && ckWARN(WARN_PRINTF) &&
5065 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5066 SV *msg = sv_newmortal();
5067 sv_setpvf(msg, "Invalid conversion in %s: ",
5068 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5070 sv_catpvf(msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5073 sv_catpv(msg, "end of string");
5074 warner(WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5077 /* output mangled stuff ... */
5083 /* ... right here, because formatting flags should not apply */
5084 SvGROW(sv, SvCUR(sv) + elen + 1);
5086 memcpy(p, eptr, elen);
5089 SvCUR(sv) = p - SvPVX(sv);
5090 continue; /* not "break" */
5093 have = esignlen + zeros + elen;
5094 need = (have > width ? have : width);
5097 SvGROW(sv, SvCUR(sv) + need + 1);
5099 if (esignlen && fill == '0') {
5100 for (i = 0; i < esignlen; i++)
5104 memset(p, fill, gap);
5107 if (esignlen && fill != '0') {
5108 for (i = 0; i < esignlen; i++)
5112 for (i = zeros; i; i--)
5116 memcpy(p, eptr, elen);
5120 memset(p, ' ', gap);
5124 SvCUR(sv) = p - SvPVX(sv);