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 VTBL this->*vtbl
42 #else /* !PERL_OBJECT */
44 #endif /* PERL_OBJECT */
47 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
49 static void do_report_used(pTHXo_ SV *sv);
50 static void do_clean_objs(pTHXo_ SV *sv);
51 #ifndef DISABLE_DESTRUCTOR_KLUDGE
52 static void do_clean_named_objs(pTHXo_ SV *sv);
54 static void do_clean_all(pTHXo_ SV *sv);
62 (p) = (SV*)safemalloc(sizeof(SV)); \
74 Safefree((char*)(p)); \
79 static I32 registry_size;
81 #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
83 #define REG_REPLACE(sv,a,b) \
85 void* p = sv->sv_any; \
86 I32 h = REGHASH(sv, registry_size); \
88 while (registry[i] != (a)) { \
89 if (++i >= registry_size) \
92 Perl_die(aTHX_ "SV registry bug"); \
97 #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
98 #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
101 S_reg_add(pTHX_ SV *sv)
103 if (PL_sv_count >= (registry_size >> 1))
105 SV **oldreg = registry;
106 I32 oldsize = registry_size;
108 registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
109 Newz(707, registry, registry_size, SV*);
114 for (i = 0; i < oldsize; ++i) {
115 SV* oldsv = oldreg[i];
128 S_reg_remove(pTHX_ SV *sv)
135 S_visit(pTHX_ SVFUNC_t f)
139 for (i = 0; i < registry_size; ++i) {
140 SV* sv = registry[i];
141 if (sv && SvTYPE(sv) != SVTYPEMASK)
147 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
149 if (!(flags & SVf_FAKE))
156 * "A time to plant, and a time to uproot what was planted..."
159 #define plant_SV(p) \
161 SvANY(p) = (void *)PL_sv_root; \
162 SvFLAGS(p) = SVTYPEMASK; \
167 /* sv_mutex must be held while calling uproot_SV() */
168 #define uproot_SV(p) \
171 PL_sv_root = (SV*)SvANY(p); \
193 if (PL_debug & 32768) \
201 S_del_sv(pTHX_ SV *p)
203 if (PL_debug & 32768) {
208 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
210 svend = &sva[SvREFCNT(sva)];
211 if (p >= sv && p < svend)
215 if (ckWARN_d(WARN_INTERNAL))
216 Perl_warner(aTHX_ WARN_INTERNAL,
217 "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
224 #else /* ! DEBUGGING */
226 #define del_SV(p) plant_SV(p)
228 #endif /* DEBUGGING */
231 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
236 Zero(sva, size, char);
238 /* The first SV in an arena isn't an SV. */
239 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
240 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
241 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
243 PL_sv_arenaroot = sva;
244 PL_sv_root = sva + 1;
246 svend = &sva[SvREFCNT(sva) - 1];
249 SvANY(sv) = (void *)(SV*)(sv + 1);
250 SvFLAGS(sv) = SVTYPEMASK;
254 SvFLAGS(sv) = SVTYPEMASK;
257 /* sv_mutex must be held while calling more_sv() */
264 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
265 PL_nice_chunk = Nullch;
268 char *chunk; /* must use New here to match call to */
269 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
270 sv_add_arena(chunk, 1008, 0);
277 S_visit(pTHX_ SVFUNC_t f)
283 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
284 svend = &sva[SvREFCNT(sva)];
285 for (sv = sva + 1; sv < svend; ++sv) {
286 if (SvTYPE(sv) != SVTYPEMASK)
295 Perl_sv_report_used(pTHX)
297 visit(FUNC_NAME_TO_PTR(do_report_used));
301 Perl_sv_clean_objs(pTHX)
303 PL_in_clean_objs = TRUE;
304 visit(FUNC_NAME_TO_PTR(do_clean_objs));
305 #ifndef DISABLE_DESTRUCTOR_KLUDGE
306 /* some barnacles may yet remain, clinging to typeglobs */
307 visit(FUNC_NAME_TO_PTR(do_clean_named_objs));
309 PL_in_clean_objs = FALSE;
313 Perl_sv_clean_all(pTHX)
315 PL_in_clean_all = TRUE;
316 visit(FUNC_NAME_TO_PTR(do_clean_all));
317 PL_in_clean_all = FALSE;
321 Perl_sv_free_arenas(pTHX)
326 /* Free arenas here, but be careful about fake ones. (We assume
327 contiguity of the fake ones with the corresponding real ones.) */
329 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
330 svanext = (SV*) SvANY(sva);
331 while (svanext && SvFAKE(svanext))
332 svanext = (SV*) SvANY(svanext);
335 Safefree((void *)sva);
339 Safefree(PL_nice_chunk);
340 PL_nice_chunk = Nullch;
341 PL_nice_chunk_size = 0;
355 * See comment in more_xiv() -- RAM.
357 PL_xiv_root = *(IV**)xiv;
359 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
363 S_del_xiv(pTHX_ XPVIV *p)
365 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
367 *(IV**)xiv = PL_xiv_root;
378 New(705, ptr, 1008/sizeof(XPV), XPV);
379 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
380 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
383 xivend = &xiv[1008 / sizeof(IV) - 1];
384 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
386 while (xiv < xivend) {
387 *(IV**)xiv = (IV *)(xiv + 1);
401 PL_xnv_root = *(NV**)xnv;
403 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
407 S_del_xnv(pTHX_ XPVNV *p)
409 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
411 *(NV**)xnv = PL_xnv_root;
421 New(711, xnv, 1008/sizeof(NV), NV);
422 xnvend = &xnv[1008 / sizeof(NV) - 1];
423 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
425 while (xnv < xnvend) {
426 *(NV**)xnv = (NV*)(xnv + 1);
440 PL_xrv_root = (XRV*)xrv->xrv_rv;
446 S_del_xrv(pTHX_ XRV *p)
449 p->xrv_rv = (SV*)PL_xrv_root;
458 register XRV* xrvend;
459 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
461 xrvend = &xrv[1008 / sizeof(XRV) - 1];
462 while (xrv < xrvend) {
463 xrv->xrv_rv = (SV*)(xrv + 1);
477 PL_xpv_root = (XPV*)xpv->xpv_pv;
483 S_del_xpv(pTHX_ XPV *p)
486 p->xpv_pv = (char*)PL_xpv_root;
495 register XPV* xpvend;
496 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
498 xpvend = &xpv[1008 / sizeof(XPV) - 1];
499 while (xpv < xpvend) {
500 xpv->xpv_pv = (char*)(xpv + 1);
507 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
508 #define del_XIV(p) Safefree((char*)p)
510 #define new_XIV() (void*)new_xiv()
511 #define del_XIV(p) del_xiv((XPVIV*) p)
515 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
516 #define del_XNV(p) Safefree((char*)p)
518 #define new_XNV() (void*)new_xnv()
519 #define del_XNV(p) del_xnv((XPVNV*) p)
523 #define new_XRV() (void*)safemalloc(sizeof(XRV))
524 #define del_XRV(p) Safefree((char*)p)
526 #define new_XRV() (void*)new_xrv()
527 #define del_XRV(p) del_xrv((XRV*) p)
531 #define new_XPV() (void*)safemalloc(sizeof(XPV))
532 #define del_XPV(p) Safefree((char*)p)
534 #define new_XPV() (void*)new_xpv()
535 #define del_XPV(p) del_xpv((XPV *)p)
539 # define my_safemalloc(s) safemalloc(s)
540 # define my_safefree(s) safefree(s)
543 S_my_safemalloc(MEM_SIZE size)
546 New(717, p, size, char);
549 # define my_safefree(s) Safefree(s)
552 #define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
553 #define del_XPVIV(p) my_safefree((char*)p)
555 #define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
556 #define del_XPVNV(p) my_safefree((char*)p)
558 #define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
559 #define del_XPVMG(p) my_safefree((char*)p)
561 #define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
562 #define del_XPVLV(p) my_safefree((char*)p)
564 #define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
565 #define del_XPVAV(p) my_safefree((char*)p)
567 #define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
568 #define del_XPVHV(p) my_safefree((char*)p)
570 #define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
571 #define del_XPVCV(p) my_safefree((char*)p)
573 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
574 #define del_XPVGV(p) my_safefree((char*)p)
576 #define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
577 #define del_XPVBM(p) my_safefree((char*)p)
579 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
580 #define del_XPVFM(p) my_safefree((char*)p)
582 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
583 #define del_XPVIO(p) my_safefree((char*)p)
586 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
596 if (SvTYPE(sv) == mt)
602 switch (SvTYPE(sv)) {
623 else if (mt < SVt_PVIV)
640 pv = (char*)SvRV(sv);
644 nv = (NV)(unsigned long)pv;
660 else if (mt == SVt_NV)
671 del_XPVIV(SvANY(sv));
681 del_XPVNV(SvANY(sv));
691 del_XPVMG(SvANY(sv));
694 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
699 Perl_croak(aTHX_ "Can't upgrade to undef");
701 SvANY(sv) = new_XIV();
705 SvANY(sv) = new_XNV();
709 SvANY(sv) = new_XRV();
713 SvANY(sv) = new_XPV();
719 SvANY(sv) = new_XPVIV();
729 SvANY(sv) = new_XPVNV();
737 SvANY(sv) = new_XPVMG();
747 SvANY(sv) = new_XPVLV();
761 SvANY(sv) = new_XPVAV();
776 SvANY(sv) = new_XPVHV();
792 SvANY(sv) = new_XPVCV();
793 Zero(SvANY(sv), 1, XPVCV);
803 SvANY(sv) = new_XPVGV();
818 SvANY(sv) = new_XPVBM();
831 SvANY(sv) = new_XPVFM();
832 Zero(SvANY(sv), 1, XPVFM);
842 SvANY(sv) = new_XPVIO();
843 Zero(SvANY(sv), 1, XPVIO);
854 SvFLAGS(sv) &= ~SVTYPEMASK;
860 Perl_sv_backoff(pTHX_ register SV *sv)
865 SvLEN(sv) += SvIVX(sv);
866 SvPVX(sv) -= SvIVX(sv);
868 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
870 SvFLAGS(sv) &= ~SVf_OOK;
875 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
880 if (newlen >= 0x10000) {
881 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
884 #endif /* HAS_64K_LIMIT */
887 if (SvTYPE(sv) < SVt_PV) {
888 sv_upgrade(sv, SVt_PV);
891 else if (SvOOK(sv)) { /* pv is offset? */
894 if (newlen > SvLEN(sv))
895 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
897 if (newlen >= 0x10000)
903 if (newlen > SvLEN(sv)) { /* need more room? */
904 if (SvLEN(sv) && s) {
905 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
906 STRLEN l = malloced_size((void*)SvPVX(sv));
912 Renew(s,newlen,char);
915 New(703,s,newlen,char);
917 SvLEN_set(sv, newlen);
923 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
925 SV_CHECK_THINKFIRST(sv);
926 switch (SvTYPE(sv)) {
928 sv_upgrade(sv, SVt_IV);
931 sv_upgrade(sv, SVt_PVNV);
935 sv_upgrade(sv, SVt_PVIV);
946 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
947 PL_op_desc[PL_op->op_type]);
950 (void)SvIOK_only(sv); /* validate number */
956 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
963 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
971 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
978 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
980 SV_CHECK_THINKFIRST(sv);
981 switch (SvTYPE(sv)) {
984 sv_upgrade(sv, SVt_NV);
989 sv_upgrade(sv, SVt_PVNV);
1000 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1001 PL_op_name[PL_op->op_type]);
1005 (void)SvNOK_only(sv); /* validate number */
1010 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1017 S_not_a_number(pTHX_ SV *sv)
1023 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1024 /* each *s can expand to 4 chars + "...\0",
1025 i.e. need room for 8 chars */
1027 for (s = SvPVX(sv); *s && d < limit; s++) {
1029 if (ch & 128 && !isPRINT_LC(ch)) {
1038 else if (ch == '\r') {
1042 else if (ch == '\f') {
1046 else if (ch == '\\') {
1050 else if (isPRINT_LC(ch))
1065 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
1066 PL_op_name[PL_op->op_type]);
1068 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
1071 /* the number can be converted to _integer_ with atol() */
1072 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1073 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1074 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1075 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1077 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1078 until proven guilty, assume that things are not that bad... */
1081 Perl_sv_2iv(pTHX_ register SV *sv)
1085 if (SvGMAGICAL(sv)) {
1090 return I_V(SvNVX(sv));
1092 if (SvPOKp(sv) && SvLEN(sv))
1095 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1097 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1098 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1103 if (SvTHINKFIRST(sv)) {
1106 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1107 return SvIV(tmpstr);
1108 return (IV)SvRV(sv);
1110 if (SvREADONLY(sv)) {
1112 return I_V(SvNVX(sv));
1114 if (SvPOKp(sv) && SvLEN(sv))
1118 if (ckWARN(WARN_UNINITIALIZED))
1119 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1126 return (IV)(SvUVX(sv));
1133 /* We can cache the IV/UV value even if it not good enough
1134 * to reconstruct NV, since the conversion to PV will prefer
1135 * NV over IV/UV. XXXX 64-bit?
1138 if (SvTYPE(sv) == SVt_NV)
1139 sv_upgrade(sv, SVt_PVNV);
1142 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1143 SvIVX(sv) = I_V(SvNVX(sv));
1145 SvUVX(sv) = U_V(SvNVX(sv));
1148 DEBUG_c(PerlIO_printf(Perl_debug_log,
1149 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1151 (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
1152 return (IV)SvUVX(sv);
1155 else if (SvPOKp(sv) && SvLEN(sv)) {
1156 I32 numtype = looks_like_number(sv);
1158 /* We want to avoid a possible problem when we cache an IV which
1159 may be later translated to an NV, and the resulting NV is not
1160 the translation of the initial data.
1162 This means that if we cache such an IV, we need to cache the
1163 NV as well. Moreover, we trade speed for space, and do not
1164 cache the NV if not needed.
1166 if (numtype & IS_NUMBER_NOT_IV) {
1167 /* May be not an integer. Need to cache NV if we cache IV
1168 * - otherwise future conversion to NV will be wrong. */
1171 d = Atof(SvPVX(sv));
1173 if (SvTYPE(sv) < SVt_PVNV)
1174 sv_upgrade(sv, SVt_PVNV);
1178 #if defined(USE_LONG_DOUBLE)
1179 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1180 (unsigned long)sv, SvNVX(sv)));
1182 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1183 (unsigned long)sv, SvNVX(sv)));
1185 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1186 SvIVX(sv) = I_V(SvNVX(sv));
1188 SvUVX(sv) = U_V(SvNVX(sv));
1194 /* The NV may be reconstructed from IV - safe to cache IV,
1195 which may be calculated by atol(). */
1196 if (SvTYPE(sv) == SVt_PV)
1197 sv_upgrade(sv, SVt_PVIV);
1199 SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
1201 else { /* Not a number. Cache 0. */
1204 if (SvTYPE(sv) < SVt_PVIV)
1205 sv_upgrade(sv, SVt_PVIV);
1208 if (ckWARN(WARN_NUMERIC))
1214 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1215 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1216 if (SvTYPE(sv) < SVt_IV)
1217 /* Typically the caller expects that sv_any is not NULL now. */
1218 sv_upgrade(sv, SVt_IV);
1221 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1222 (unsigned long)sv,(long)SvIVX(sv)));
1223 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1227 Perl_sv_2uv(pTHX_ register SV *sv)
1231 if (SvGMAGICAL(sv)) {
1236 return U_V(SvNVX(sv));
1237 if (SvPOKp(sv) && SvLEN(sv))
1240 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1242 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1243 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1248 if (SvTHINKFIRST(sv)) {
1251 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1252 return SvUV(tmpstr);
1253 return (UV)SvRV(sv);
1255 if (SvREADONLY(sv)) {
1257 return U_V(SvNVX(sv));
1259 if (SvPOKp(sv) && SvLEN(sv))
1263 if (ckWARN(WARN_UNINITIALIZED))
1264 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1274 return (UV)SvIVX(sv);
1278 /* We can cache the IV/UV value even if it not good enough
1279 * to reconstruct NV, since the conversion to PV will prefer
1280 * NV over IV/UV. XXXX 64-bit?
1282 if (SvTYPE(sv) == SVt_NV)
1283 sv_upgrade(sv, SVt_PVNV);
1285 if (SvNVX(sv) >= -0.5) {
1287 SvUVX(sv) = U_V(SvNVX(sv));
1290 SvIVX(sv) = I_V(SvNVX(sv));
1292 DEBUG_c(PerlIO_printf(Perl_debug_log,
1293 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1294 (unsigned long)sv,(long)SvIVX(sv),
1295 (long)(UV)SvIVX(sv)));
1296 return (UV)SvIVX(sv);
1299 else if (SvPOKp(sv) && SvLEN(sv)) {
1300 I32 numtype = looks_like_number(sv);
1302 /* We want to avoid a possible problem when we cache a UV which
1303 may be later translated to an NV, and the resulting NV is not
1304 the translation of the initial data.
1306 This means that if we cache such a UV, we need to cache the
1307 NV as well. Moreover, we trade speed for space, and do not
1308 cache the NV if not needed.
1310 if (numtype & IS_NUMBER_NOT_IV) {
1311 /* May be not an integer. Need to cache NV if we cache IV
1312 * - otherwise future conversion to NV will be wrong. */
1315 d = Atof(SvPVX(sv)); /* XXXX 64-bit? */
1317 if (SvTYPE(sv) < SVt_PVNV)
1318 sv_upgrade(sv, SVt_PVNV);
1322 #if defined(USE_LONG_DOUBLE)
1323 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1324 (unsigned long)sv, SvNVX(sv)));
1326 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1327 (unsigned long)sv, SvNVX(sv)));
1329 if (SvNVX(sv) < -0.5) {
1330 SvIVX(sv) = I_V(SvNVX(sv));
1333 SvUVX(sv) = U_V(SvNVX(sv));
1337 else if (numtype & IS_NUMBER_NEG) {
1338 /* The NV may be reconstructed from IV - safe to cache IV,
1339 which may be calculated by atol(). */
1340 if (SvTYPE(sv) == SVt_PV)
1341 sv_upgrade(sv, SVt_PVIV);
1343 SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1345 else if (numtype) { /* Non-negative */
1346 /* The NV may be reconstructed from UV - safe to cache UV,
1347 which may be calculated by strtoul()/atol. */
1348 if (SvTYPE(sv) == SVt_PV)
1349 sv_upgrade(sv, SVt_PVIV);
1351 (void)SvIsUV_on(sv);
1353 SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
1354 #else /* no atou(), but we know the number fits into IV... */
1355 /* The only problem may be if it is negative... */
1356 SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1359 else { /* Not a number. Cache 0. */
1362 if (SvTYPE(sv) < SVt_PVIV)
1363 sv_upgrade(sv, SVt_PVIV);
1364 SvUVX(sv) = 0; /* We assume that 0s have the
1365 same bitmap in IV and UV. */
1367 (void)SvIsUV_on(sv);
1368 if (ckWARN(WARN_NUMERIC))
1373 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1375 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1376 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1378 if (SvTYPE(sv) < SVt_IV)
1379 /* Typically the caller expects that sv_any is not NULL now. */
1380 sv_upgrade(sv, SVt_IV);
1384 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1385 (unsigned long)sv,SvUVX(sv)));
1386 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1390 Perl_sv_2nv(pTHX_ register SV *sv)
1394 if (SvGMAGICAL(sv)) {
1398 if (SvPOKp(sv) && SvLEN(sv)) {
1400 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1402 return Atof(SvPVX(sv));
1406 return (NV)SvUVX(sv);
1408 return (NV)SvIVX(sv);
1411 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1413 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1414 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1419 if (SvTHINKFIRST(sv)) {
1422 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1423 return SvNV(tmpstr);
1424 return (NV)(unsigned long)SvRV(sv);
1426 if (SvREADONLY(sv)) {
1428 if (SvPOKp(sv) && SvLEN(sv)) {
1429 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1431 return Atof(SvPVX(sv));
1435 return (NV)SvUVX(sv);
1437 return (NV)SvIVX(sv);
1439 if (ckWARN(WARN_UNINITIALIZED))
1440 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1444 if (SvTYPE(sv) < SVt_NV) {
1445 if (SvTYPE(sv) == SVt_IV)
1446 sv_upgrade(sv, SVt_PVNV);
1448 sv_upgrade(sv, SVt_NV);
1449 #if defined(USE_LONG_DOUBLE)
1451 RESTORE_NUMERIC_STANDARD();
1452 PerlIO_printf(Perl_debug_log, "0x%lx num(%Lg)\n",
1453 (unsigned long)sv, SvNVX(sv));
1454 RESTORE_NUMERIC_LOCAL();
1458 RESTORE_NUMERIC_STANDARD();
1459 PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
1460 (unsigned long)sv, SvNVX(sv));
1461 RESTORE_NUMERIC_LOCAL();
1465 else if (SvTYPE(sv) < SVt_PVNV)
1466 sv_upgrade(sv, SVt_PVNV);
1468 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1470 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1472 else if (SvPOKp(sv) && SvLEN(sv)) {
1474 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1476 SvNVX(sv) = Atof(SvPVX(sv));
1480 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1481 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1482 if (SvTYPE(sv) < SVt_NV)
1483 /* Typically the caller expects that sv_any is not NULL now. */
1484 sv_upgrade(sv, SVt_NV);
1488 #if defined(USE_LONG_DOUBLE)
1490 RESTORE_NUMERIC_STANDARD();
1491 PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1492 (unsigned long)sv, SvNVX(sv));
1493 RESTORE_NUMERIC_LOCAL();
1497 RESTORE_NUMERIC_STANDARD();
1498 PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
1499 (unsigned long)sv, SvNVX(sv));
1500 RESTORE_NUMERIC_LOCAL();
1507 S_asIV(pTHX_ SV *sv)
1509 I32 numtype = looks_like_number(sv);
1512 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1513 return atol(SvPVX(sv)); /* XXXX 64-bit? */
1516 if (ckWARN(WARN_NUMERIC))
1519 d = Atof(SvPVX(sv));
1524 S_asUV(pTHX_ SV *sv)
1526 I32 numtype = looks_like_number(sv);
1529 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1530 return strtoul(SvPVX(sv), Null(char**), 10);
1534 if (ckWARN(WARN_NUMERIC))
1537 return U_V(Atof(SvPVX(sv)));
1541 * Returns a combination of (advisory only - can get false negatives)
1542 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1544 * 0 if does not look like number.
1546 * In fact possible values are 0 and
1547 * IS_NUMBER_TO_INT_BY_ATOL 123
1548 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1549 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1550 * with a possible addition of IS_NUMBER_NEG.
1554 Perl_looks_like_number(pTHX_ SV *sv)
1556 /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
1557 * using atof() may lose precision. */
1559 register char *send;
1560 register char *sbegin;
1561 register char *nbegin;
1569 else if (SvPOKp(sv))
1570 sbegin = SvPV(sv, len);
1573 send = sbegin + len;
1580 numtype = IS_NUMBER_NEG;
1587 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1588 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1592 /* next must be digit or the radix separator */
1596 } while (isDIGIT(*s));
1598 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1599 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1601 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1604 #ifdef USE_LOCALE_NUMERIC
1605 || IS_NUMERIC_RADIX(*s)
1609 numtype |= IS_NUMBER_NOT_IV;
1610 while (isDIGIT(*s)) /* optional digits after the radix */
1615 #ifdef USE_LOCALE_NUMERIC
1616 || IS_NUMERIC_RADIX(*s)
1620 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1621 /* no digits before the radix means we need digits after it */
1625 } while (isDIGIT(*s));
1633 /* we can have an optional exponent part */
1634 if (*s == 'e' || *s == 'E') {
1635 numtype &= ~IS_NUMBER_NEG;
1636 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1638 if (*s == '+' || *s == '-')
1643 } while (isDIGIT(*s));
1652 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1653 return IS_NUMBER_TO_INT_BY_ATOL;
1658 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1661 return sv_2pv(sv, &n_a);
1664 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1666 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1669 char *ptr = buf + TYPE_CHARS(UV);
1684 *--ptr = '0' + (uv % 10);
1693 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1698 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1699 char *tmpbuf = tbuf;
1705 if (SvGMAGICAL(sv)) {
1711 if (SvIOKp(sv)) { /* XXXX 64-bit? */
1713 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1715 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1720 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1725 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1727 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1728 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1734 if (SvTHINKFIRST(sv)) {
1737 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1738 return SvPV(tmpstr,*lp);
1745 switch (SvTYPE(sv)) {
1747 if ( ((SvFLAGS(sv) &
1748 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1749 == (SVs_OBJECT|SVs_RMG))
1750 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1751 && (mg = mg_find(sv, 'r'))) {
1753 regexp *re = (regexp *)mg->mg_obj;
1756 char *fptr = "msix";
1761 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1763 while(ch = *fptr++) {
1765 reflags[left++] = ch;
1768 reflags[right--] = ch;
1773 reflags[left] = '-';
1777 mg->mg_len = re->prelen + 4 + left;
1778 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1779 Copy("(?", mg->mg_ptr, 2, char);
1780 Copy(reflags, mg->mg_ptr+2, left, char);
1781 Copy(":", mg->mg_ptr+left+2, 1, char);
1782 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1783 mg->mg_ptr[mg->mg_len - 1] = ')';
1784 mg->mg_ptr[mg->mg_len] = 0;
1786 PL_reginterp_cnt += re->program[0].next_off;
1798 case SVt_PVBM: s = "SCALAR"; break;
1799 case SVt_PVLV: s = "LVALUE"; break;
1800 case SVt_PVAV: s = "ARRAY"; break;
1801 case SVt_PVHV: s = "HASH"; break;
1802 case SVt_PVCV: s = "CODE"; break;
1803 case SVt_PVGV: s = "GLOB"; break;
1804 case SVt_PVFM: s = "FORMAT"; break;
1805 case SVt_PVIO: s = "IO"; break;
1806 default: s = "UNKNOWN"; break;
1810 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1814 Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
1820 if (SvREADONLY(sv)) {
1821 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1822 /* XXXX 64-bit? IV may have better precision... */
1823 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1831 tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
1833 tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
1840 if (ckWARN(WARN_UNINITIALIZED))
1841 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1847 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1848 /* XXXX 64-bit? IV may have better precision... */
1849 if (SvTYPE(sv) < SVt_PVNV)
1850 sv_upgrade(sv, SVt_PVNV);
1853 olderrno = errno; /* some Xenix systems wipe out errno here */
1855 if (SvNVX(sv) == 0.0)
1856 (void)strcpy(s,"0");
1860 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1863 #ifdef FIXNEGATIVEZERO
1864 if (*s == '-' && s[1] == '0' && !s[2])
1873 else if (SvIOKp(sv)) {
1874 U32 isIOK = SvIOK(sv);
1875 char buf[TYPE_CHARS(UV)];
1878 if (SvTYPE(sv) < SVt_PVIV)
1879 sv_upgrade(sv, SVt_PVIV);
1881 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1882 sv_setpvn(sv, ptr, ebuf - ptr);
1886 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1887 sv_setpvn(sv, ptr, ebuf - ptr);
1897 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1898 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1900 if (SvTYPE(sv) < SVt_PV)
1901 /* Typically the caller expects that sv_any is not NULL now. */
1902 sv_upgrade(sv, SVt_PV);
1905 *lp = s - SvPVX(sv);
1908 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1912 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1913 /* Sneaky stuff here */
1917 tsv = newSVpv(tmpbuf, 0);
1933 len = strlen(tmpbuf);
1935 #ifdef FIXNEGATIVEZERO
1936 if (len == 2 && t[0] == '-' && t[1] == '0') {
1941 (void)SvUPGRADE(sv, SVt_PV);
1943 s = SvGROW(sv, len + 1);
1951 /* This function is only called on magical items */
1953 Perl_sv_2bool(pTHX_ register SV *sv)
1963 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1964 return SvTRUE(tmpsv);
1965 return SvRV(sv) != 0;
1968 register XPV* Xpvtmp;
1969 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1970 (*Xpvtmp->xpv_pv > '0' ||
1971 Xpvtmp->xpv_cur > 1 ||
1972 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
1979 return SvIVX(sv) != 0;
1982 return SvNVX(sv) != 0.0;
1989 /* Note: sv_setsv() should not be called with a source string that needs
1990 * to be reused, since it may destroy the source string if it is marked
1995 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
1998 register U32 sflags;
2004 SV_CHECK_THINKFIRST(dstr);
2006 sstr = &PL_sv_undef;
2007 stype = SvTYPE(sstr);
2008 dtype = SvTYPE(dstr);
2012 /* There's a lot of redundancy below but we're going for speed here */
2017 if (dtype != SVt_PVGV) {
2018 (void)SvOK_off(dstr);
2026 sv_upgrade(dstr, SVt_IV);
2029 sv_upgrade(dstr, SVt_PVNV);
2033 sv_upgrade(dstr, SVt_PVIV);
2036 (void)SvIOK_only(dstr);
2037 SvIVX(dstr) = SvIVX(sstr);
2050 sv_upgrade(dstr, SVt_NV);
2055 sv_upgrade(dstr, SVt_PVNV);
2058 SvNVX(dstr) = SvNVX(sstr);
2059 (void)SvNOK_only(dstr);
2067 sv_upgrade(dstr, SVt_RV);
2068 else if (dtype == SVt_PVGV &&
2069 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2072 if (PL_curcop->cop_stash != GvSTASH(dstr))
2073 GvIMPORTED_on(dstr);
2083 sv_upgrade(dstr, SVt_PV);
2086 if (dtype < SVt_PVIV)
2087 sv_upgrade(dstr, SVt_PVIV);
2090 if (dtype < SVt_PVNV)
2091 sv_upgrade(dstr, SVt_PVNV);
2098 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2099 PL_op_name[PL_op->op_type]);
2101 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2105 if (dtype <= SVt_PVGV) {
2107 if (dtype != SVt_PVGV) {
2108 char *name = GvNAME(sstr);
2109 STRLEN len = GvNAMELEN(sstr);
2110 sv_upgrade(dstr, SVt_PVGV);
2111 sv_magic(dstr, dstr, '*', name, len);
2112 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2113 GvNAME(dstr) = savepvn(name, len);
2114 GvNAMELEN(dstr) = len;
2115 SvFAKE_on(dstr); /* can coerce to non-glob */
2117 /* ahem, death to those who redefine active sort subs */
2118 else if (PL_curstackinfo->si_type == PERLSI_SORT
2119 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2120 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2122 (void)SvOK_off(dstr);
2123 GvINTRO_off(dstr); /* one-shot flag */
2125 GvGP(dstr) = gp_ref(GvGP(sstr));
2127 if (PL_curcop->cop_stash != GvSTASH(dstr))
2128 GvIMPORTED_on(dstr);
2135 if (SvGMAGICAL(sstr)) {
2137 if (SvTYPE(sstr) != stype) {
2138 stype = SvTYPE(sstr);
2139 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2143 if (stype == SVt_PVLV)
2144 (void)SvUPGRADE(dstr, SVt_PVNV);
2146 (void)SvUPGRADE(dstr, stype);
2149 sflags = SvFLAGS(sstr);
2151 if (sflags & SVf_ROK) {
2152 if (dtype >= SVt_PV) {
2153 if (dtype == SVt_PVGV) {
2154 SV *sref = SvREFCNT_inc(SvRV(sstr));
2156 int intro = GvINTRO(dstr);
2160 GvGP(dstr)->gp_refcnt--;
2161 GvINTRO_off(dstr); /* one-shot flag */
2162 Newz(602,gp, 1, GP);
2163 GvGP(dstr) = gp_ref(gp);
2164 GvSV(dstr) = NEWSV(72,0);
2165 GvLINE(dstr) = PL_curcop->cop_line;
2166 GvEGV(dstr) = (GV*)dstr;
2169 switch (SvTYPE(sref)) {
2172 SAVESPTR(GvAV(dstr));
2174 dref = (SV*)GvAV(dstr);
2175 GvAV(dstr) = (AV*)sref;
2176 if (PL_curcop->cop_stash != GvSTASH(dstr))
2177 GvIMPORTED_AV_on(dstr);
2181 SAVESPTR(GvHV(dstr));
2183 dref = (SV*)GvHV(dstr);
2184 GvHV(dstr) = (HV*)sref;
2185 if (PL_curcop->cop_stash != GvSTASH(dstr))
2186 GvIMPORTED_HV_on(dstr);
2190 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2191 SvREFCNT_dec(GvCV(dstr));
2192 GvCV(dstr) = Nullcv;
2193 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2194 PL_sub_generation++;
2196 SAVESPTR(GvCV(dstr));
2199 dref = (SV*)GvCV(dstr);
2200 if (GvCV(dstr) != (CV*)sref) {
2201 CV* cv = GvCV(dstr);
2203 if (!GvCVGEN((GV*)dstr) &&
2204 (CvROOT(cv) || CvXSUB(cv)))
2206 SV *const_sv = cv_const_sv(cv);
2207 bool const_changed = TRUE;
2209 const_changed = sv_cmp(const_sv,
2210 op_const_sv(CvSTART((CV*)sref),
2212 /* ahem, death to those who redefine
2213 * active sort subs */
2214 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2215 PL_sortcop == CvSTART(cv))
2217 "Can't redefine active sort subroutine %s",
2218 GvENAME((GV*)dstr));
2219 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2220 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2221 && HvNAME(GvSTASH(CvGV(cv)))
2222 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2224 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2225 "Constant subroutine %s redefined"
2226 : "Subroutine %s redefined",
2227 GvENAME((GV*)dstr));
2230 cv_ckproto(cv, (GV*)dstr,
2231 SvPOK(sref) ? SvPVX(sref) : Nullch);
2233 GvCV(dstr) = (CV*)sref;
2234 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2235 GvASSUMECV_on(dstr);
2236 PL_sub_generation++;
2238 if (PL_curcop->cop_stash != GvSTASH(dstr))
2239 GvIMPORTED_CV_on(dstr);
2243 SAVESPTR(GvIOp(dstr));
2245 dref = (SV*)GvIOp(dstr);
2246 GvIOp(dstr) = (IO*)sref;
2250 SAVESPTR(GvSV(dstr));
2252 dref = (SV*)GvSV(dstr);
2254 if (PL_curcop->cop_stash != GvSTASH(dstr))
2255 GvIMPORTED_SV_on(dstr);
2266 (void)SvOOK_off(dstr); /* backoff */
2268 Safefree(SvPVX(dstr));
2269 SvLEN(dstr)=SvCUR(dstr)=0;
2272 (void)SvOK_off(dstr);
2273 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2275 if (sflags & SVp_NOK) {
2277 SvNVX(dstr) = SvNVX(sstr);
2279 if (sflags & SVp_IOK) {
2280 (void)SvIOK_on(dstr);
2281 SvIVX(dstr) = SvIVX(sstr);
2285 if (SvAMAGIC(sstr)) {
2289 else if (sflags & SVp_POK) {
2292 * Check to see if we can just swipe the string. If so, it's a
2293 * possible small lose on short strings, but a big win on long ones.
2294 * It might even be a win on short strings if SvPVX(dstr)
2295 * has to be allocated and SvPVX(sstr) has to be freed.
2298 if (SvTEMP(sstr) && /* slated for free anyway? */
2299 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2300 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2302 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2304 SvFLAGS(dstr) &= ~SVf_OOK;
2305 Safefree(SvPVX(dstr) - SvIVX(dstr));
2307 else if (SvLEN(dstr))
2308 Safefree(SvPVX(dstr));
2310 (void)SvPOK_only(dstr);
2311 SvPV_set(dstr, SvPVX(sstr));
2312 SvLEN_set(dstr, SvLEN(sstr));
2313 SvCUR_set(dstr, SvCUR(sstr));
2315 (void)SvOK_off(sstr);
2316 SvPV_set(sstr, Nullch);
2321 else { /* have to copy actual string */
2322 STRLEN len = SvCUR(sstr);
2324 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2325 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2326 SvCUR_set(dstr, len);
2327 *SvEND(dstr) = '\0';
2328 (void)SvPOK_only(dstr);
2331 if (sflags & SVp_NOK) {
2333 SvNVX(dstr) = SvNVX(sstr);
2335 if (sflags & SVp_IOK) {
2336 (void)SvIOK_on(dstr);
2337 SvIVX(dstr) = SvIVX(sstr);
2342 else if (sflags & SVp_NOK) {
2343 SvNVX(dstr) = SvNVX(sstr);
2344 (void)SvNOK_only(dstr);
2346 (void)SvIOK_on(dstr);
2347 SvIVX(dstr) = SvIVX(sstr);
2348 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2353 else if (sflags & SVp_IOK) {
2354 (void)SvIOK_only(dstr);
2355 SvIVX(dstr) = SvIVX(sstr);
2360 if (dtype == SVt_PVGV) {
2361 if (ckWARN(WARN_UNSAFE))
2362 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2365 (void)SvOK_off(dstr);
2371 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2373 sv_setsv(dstr,sstr);
2378 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2380 register char *dptr;
2381 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2382 elicit a warning, but it won't hurt. */
2383 SV_CHECK_THINKFIRST(sv);
2388 (void)SvUPGRADE(sv, SVt_PV);
2390 SvGROW(sv, len + 1);
2392 Move(ptr,dptr,len,char);
2395 (void)SvPOK_only(sv); /* validate pointer */
2400 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2402 sv_setpvn(sv,ptr,len);
2407 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2409 register STRLEN len;
2411 SV_CHECK_THINKFIRST(sv);
2417 (void)SvUPGRADE(sv, SVt_PV);
2419 SvGROW(sv, len + 1);
2420 Move(ptr,SvPVX(sv),len+1,char);
2422 (void)SvPOK_only(sv); /* validate pointer */
2427 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2434 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2436 SV_CHECK_THINKFIRST(sv);
2437 (void)SvUPGRADE(sv, SVt_PV);
2442 (void)SvOOK_off(sv);
2443 if (SvPVX(sv) && SvLEN(sv))
2444 Safefree(SvPVX(sv));
2445 Renew(ptr, len+1, char);
2448 SvLEN_set(sv, len+1);
2450 (void)SvPOK_only(sv); /* validate pointer */
2455 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2457 sv_usepvn(sv,ptr,len);
2462 Perl_sv_force_normal(pTHX_ register SV *sv)
2464 if (SvREADONLY(sv)) {
2466 if (PL_curcop != &PL_compiling)
2467 Perl_croak(aTHX_ PL_no_modify);
2471 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2476 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2480 register STRLEN delta;
2482 if (!ptr || !SvPOKp(sv))
2484 SV_CHECK_THINKFIRST(sv);
2485 if (SvTYPE(sv) < SVt_PVIV)
2486 sv_upgrade(sv,SVt_PVIV);
2489 if (!SvLEN(sv)) { /* make copy of shared string */
2490 char *pvx = SvPVX(sv);
2491 STRLEN len = SvCUR(sv);
2492 SvGROW(sv, len + 1);
2493 Move(pvx,SvPVX(sv),len,char);
2497 SvFLAGS(sv) |= SVf_OOK;
2499 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2500 delta = ptr - SvPVX(sv);
2508 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2513 junk = SvPV_force(sv, tlen);
2514 SvGROW(sv, tlen + len + 1);
2517 Move(ptr,SvPVX(sv)+tlen,len,char);
2520 (void)SvPOK_only(sv); /* validate pointer */
2525 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2527 sv_catpvn(sv,ptr,len);
2532 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2538 if (s = SvPV(sstr, len))
2539 sv_catpvn(dstr,s,len);
2543 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2545 sv_catsv(dstr,sstr);
2550 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2552 register STRLEN len;
2558 junk = SvPV_force(sv, tlen);
2560 SvGROW(sv, tlen + len + 1);
2563 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2565 (void)SvPOK_only(sv); /* validate pointer */
2570 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2577 Perl_newSV(pTHX_ STRLEN len)
2583 sv_upgrade(sv, SVt_PV);
2584 SvGROW(sv, len + 1);
2589 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2592 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2596 if (SvREADONLY(sv)) {
2598 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2599 Perl_croak(aTHX_ PL_no_modify);
2601 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2602 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2609 (void)SvUPGRADE(sv, SVt_PVMG);
2611 Newz(702,mg, 1, MAGIC);
2612 mg->mg_moremagic = SvMAGIC(sv);
2615 if (!obj || obj == sv || how == '#' || how == 'r')
2619 mg->mg_obj = SvREFCNT_inc(obj);
2620 mg->mg_flags |= MGf_REFCOUNTED;
2623 mg->mg_len = namlen;
2626 mg->mg_ptr = savepvn(name, namlen);
2627 else if (namlen == HEf_SVKEY)
2628 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2632 mg->mg_virtual = &PL_vtbl_sv;
2635 mg->mg_virtual = &PL_vtbl_amagic;
2638 mg->mg_virtual = &PL_vtbl_amagicelem;
2644 mg->mg_virtual = &PL_vtbl_bm;
2647 mg->mg_virtual = &PL_vtbl_regdata;
2650 mg->mg_virtual = &PL_vtbl_regdatum;
2653 mg->mg_virtual = &PL_vtbl_env;
2656 mg->mg_virtual = &PL_vtbl_fm;
2659 mg->mg_virtual = &PL_vtbl_envelem;
2662 mg->mg_virtual = &PL_vtbl_mglob;
2665 mg->mg_virtual = &PL_vtbl_isa;
2668 mg->mg_virtual = &PL_vtbl_isaelem;
2671 mg->mg_virtual = &PL_vtbl_nkeys;
2678 mg->mg_virtual = &PL_vtbl_dbline;
2682 mg->mg_virtual = &PL_vtbl_mutex;
2684 #endif /* USE_THREADS */
2685 #ifdef USE_LOCALE_COLLATE
2687 mg->mg_virtual = &PL_vtbl_collxfrm;
2689 #endif /* USE_LOCALE_COLLATE */
2691 mg->mg_virtual = &PL_vtbl_pack;
2695 mg->mg_virtual = &PL_vtbl_packelem;
2698 mg->mg_virtual = &PL_vtbl_regexp;
2701 mg->mg_virtual = &PL_vtbl_sig;
2704 mg->mg_virtual = &PL_vtbl_sigelem;
2707 mg->mg_virtual = &PL_vtbl_taint;
2711 mg->mg_virtual = &PL_vtbl_uvar;
2714 mg->mg_virtual = &PL_vtbl_vec;
2717 mg->mg_virtual = &PL_vtbl_substr;
2720 mg->mg_virtual = &PL_vtbl_defelem;
2723 mg->mg_virtual = &PL_vtbl_glob;
2726 mg->mg_virtual = &PL_vtbl_arylen;
2729 mg->mg_virtual = &PL_vtbl_pos;
2732 mg->mg_virtual = &PL_vtbl_backref;
2734 case '~': /* Reserved for use by extensions not perl internals. */
2735 /* Useful for attaching extension internal data to perl vars. */
2736 /* Note that multiple extensions may clash if magical scalars */
2737 /* etc holding private data from one are passed to another. */
2741 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
2745 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2749 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2753 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2756 for (mg = *mgp; mg; mg = *mgp) {
2757 if (mg->mg_type == type) {
2758 MGVTBL* vtbl = mg->mg_virtual;
2759 *mgp = mg->mg_moremagic;
2760 if (vtbl && (vtbl->svt_free != NULL))
2761 (VTBL->svt_free)(aTHX_ sv, mg);
2762 if (mg->mg_ptr && mg->mg_type != 'g')
2763 if (mg->mg_len >= 0)
2764 Safefree(mg->mg_ptr);
2765 else if (mg->mg_len == HEf_SVKEY)
2766 SvREFCNT_dec((SV*)mg->mg_ptr);
2767 if (mg->mg_flags & MGf_REFCOUNTED)
2768 SvREFCNT_dec(mg->mg_obj);
2772 mgp = &mg->mg_moremagic;
2776 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2783 Perl_sv_rvweaken(pTHX_ SV *sv)
2786 if (!SvOK(sv)) /* let undefs pass */
2789 Perl_croak(aTHX_ "Can't weaken a nonreference");
2790 else if (SvWEAKREF(sv)) {
2792 if (ckWARN(WARN_MISC))
2793 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
2797 sv_add_backref(tsv, sv);
2804 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
2808 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2809 av = (AV*)mg->mg_obj;
2812 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2813 SvREFCNT_dec(av); /* for sv_magic */
2819 S_sv_del_backref(pTHX_ SV *sv)
2826 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2827 Perl_croak(aTHX_ "panic: del_backref");
2828 av = (AV *)mg->mg_obj;
2833 svp[i] = &PL_sv_undef; /* XXX */
2840 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2844 register char *midend;
2845 register char *bigend;
2851 Perl_croak(aTHX_ "Can't modify non-existent substring");
2852 SvPV_force(bigstr, curlen);
2853 if (offset + len > curlen) {
2854 SvGROW(bigstr, offset+len+1);
2855 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2856 SvCUR_set(bigstr, offset+len);
2859 i = littlelen - len;
2860 if (i > 0) { /* string might grow */
2861 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2862 mid = big + offset + len;
2863 midend = bigend = big + SvCUR(bigstr);
2866 while (midend > mid) /* shove everything down */
2867 *--bigend = *--midend;
2868 Move(little,big+offset,littlelen,char);
2874 Move(little,SvPVX(bigstr)+offset,len,char);
2879 big = SvPVX(bigstr);
2882 bigend = big + SvCUR(bigstr);
2884 if (midend > bigend)
2885 Perl_croak(aTHX_ "panic: sv_insert");
2887 if (mid - big > bigend - midend) { /* faster to shorten from end */
2889 Move(little, mid, littlelen,char);
2892 i = bigend - midend;
2894 Move(midend, mid, i,char);
2898 SvCUR_set(bigstr, mid - big);
2901 else if (i = mid - big) { /* faster from front */
2902 midend -= littlelen;
2904 sv_chop(bigstr,midend-i);
2909 Move(little, mid, littlelen,char);
2911 else if (littlelen) {
2912 midend -= littlelen;
2913 sv_chop(bigstr,midend);
2914 Move(little,midend,littlelen,char);
2917 sv_chop(bigstr,midend);
2922 /* make sv point to what nstr did */
2925 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2928 U32 refcnt = SvREFCNT(sv);
2929 SV_CHECK_THINKFIRST(sv);
2930 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
2931 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
2932 if (SvMAGICAL(sv)) {
2936 sv_upgrade(nsv, SVt_PVMG);
2937 SvMAGIC(nsv) = SvMAGIC(sv);
2938 SvFLAGS(nsv) |= SvMAGICAL(sv);
2944 assert(!SvREFCNT(sv));
2945 StructCopy(nsv,sv,SV);
2946 SvREFCNT(sv) = refcnt;
2947 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2952 Perl_sv_clear(pTHX_ register SV *sv)
2956 assert(SvREFCNT(sv) == 0);
2960 if (PL_defstash) { /* Still have a symbol table? */
2965 Zero(&tmpref, 1, SV);
2966 sv_upgrade(&tmpref, SVt_RV);
2968 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
2969 SvREFCNT(&tmpref) = 1;
2972 stash = SvSTASH(sv);
2973 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2976 PUSHSTACKi(PERLSI_DESTROY);
2977 SvRV(&tmpref) = SvREFCNT_inc(sv);
2982 call_sv((SV*)GvCV(destructor),
2983 G_DISCARD|G_EVAL|G_KEEPERR);
2989 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
2991 del_XRV(SvANY(&tmpref));
2994 if (PL_in_clean_objs)
2995 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
2997 /* DESTROY gave object new lease on life */
3003 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3004 SvOBJECT_off(sv); /* Curse the object. */
3005 if (SvTYPE(sv) != SVt_PVIO)
3006 --PL_sv_objcount; /* XXX Might want something more general */
3009 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3012 switch (SvTYPE(sv)) {
3015 IoIFP(sv) != PerlIO_stdin() &&
3016 IoIFP(sv) != PerlIO_stdout() &&
3017 IoIFP(sv) != PerlIO_stderr())
3022 PerlDir_close(IoDIRP(sv));
3025 Safefree(IoTOP_NAME(sv));
3026 Safefree(IoFMT_NAME(sv));
3027 Safefree(IoBOTTOM_NAME(sv));
3042 SvREFCNT_dec(LvTARG(sv));
3046 Safefree(GvNAME(sv));
3047 /* cannot decrease stash refcount yet, as we might recursively delete
3048 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3049 of stash until current sv is completely gone.
3050 -- JohnPC, 27 Mar 1998 */
3051 stash = GvSTASH(sv);
3057 (void)SvOOK_off(sv);
3065 SvREFCNT_dec(SvRV(sv));
3067 else if (SvPVX(sv) && SvLEN(sv))
3068 Safefree(SvPVX(sv));
3078 switch (SvTYPE(sv)) {
3094 del_XPVIV(SvANY(sv));
3097 del_XPVNV(SvANY(sv));
3100 del_XPVMG(SvANY(sv));
3103 del_XPVLV(SvANY(sv));
3106 del_XPVAV(SvANY(sv));
3109 del_XPVHV(SvANY(sv));
3112 del_XPVCV(SvANY(sv));
3115 del_XPVGV(SvANY(sv));
3116 /* code duplication for increased performance. */
3117 SvFLAGS(sv) &= SVf_BREAK;
3118 SvFLAGS(sv) |= SVTYPEMASK;
3119 /* decrease refcount of the stash that owns this GV, if any */
3121 SvREFCNT_dec(stash);
3122 return; /* not break, SvFLAGS reset already happened */
3124 del_XPVBM(SvANY(sv));
3127 del_XPVFM(SvANY(sv));
3130 del_XPVIO(SvANY(sv));
3133 SvFLAGS(sv) &= SVf_BREAK;
3134 SvFLAGS(sv) |= SVTYPEMASK;
3138 Perl_sv_newref(pTHX_ SV *sv)
3141 ATOMIC_INC(SvREFCNT(sv));
3146 Perl_sv_free(pTHX_ SV *sv)
3149 int refcount_is_zero;
3153 if (SvREFCNT(sv) == 0) {
3154 if (SvFLAGS(sv) & SVf_BREAK)
3156 if (PL_in_clean_all) /* All is fair */
3158 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3159 /* make sure SvREFCNT(sv)==0 happens very seldom */
3160 SvREFCNT(sv) = (~(U32)0)/2;
3163 if (ckWARN_d(WARN_INTERNAL))
3164 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3167 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3168 if (!refcount_is_zero)
3172 if (ckWARN_d(WARN_DEBUGGING))
3173 Perl_warner(aTHX_ WARN_DEBUGGING,
3174 "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3178 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3179 /* make sure SvREFCNT(sv)==0 happens very seldom */
3180 SvREFCNT(sv) = (~(U32)0)/2;
3189 Perl_sv_len(pTHX_ register SV *sv)
3198 len = mg_length(sv);
3200 junk = SvPV(sv, len);
3205 Perl_sv_len_utf8(pTHX_ register SV *sv)
3216 len = mg_length(sv);
3219 s = (U8*)SvPV(sv, len);
3230 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3235 I32 uoffset = *offsetp;
3241 start = s = (U8*)SvPV(sv, len);
3243 while (s < send && uoffset--)
3247 *offsetp = s - start;
3251 while (s < send && ulen--)
3261 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3270 s = (U8*)SvPV(sv, len);
3272 Perl_croak(aTHX_ "panic: bad byte offset");
3273 send = s + *offsetp;
3281 if (ckWARN_d(WARN_UTF8))
3282 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3290 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3302 pv1 = SvPV(str1, cur1);
3307 pv2 = SvPV(str2, cur2);
3312 return memEQ(pv1, pv2, cur1);
3316 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3319 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3321 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3325 return cur2 ? -1 : 0;
3330 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3333 return retval < 0 ? -1 : 1;
3338 return cur1 < cur2 ? -1 : 1;
3342 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3344 #ifdef USE_LOCALE_COLLATE
3350 if (PL_collation_standard)
3354 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3356 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3358 if (!pv1 || !len1) {
3369 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3372 return retval < 0 ? -1 : 1;
3375 * When the result of collation is equality, that doesn't mean
3376 * that there are no differences -- some locales exclude some
3377 * characters from consideration. So to avoid false equalities,
3378 * we use the raw string as a tiebreaker.
3384 #endif /* USE_LOCALE_COLLATE */
3386 return sv_cmp(sv1, sv2);
3389 #ifdef USE_LOCALE_COLLATE
3391 * Any scalar variable may carry an 'o' magic that contains the
3392 * scalar data of the variable transformed to such a format that
3393 * a normal memory comparison can be used to compare the data
3394 * according to the locale settings.
3397 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3401 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3402 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3407 Safefree(mg->mg_ptr);
3409 if ((xf = mem_collxfrm(s, len, &xlen))) {
3410 if (SvREADONLY(sv)) {
3413 return xf + sizeof(PL_collation_ix);
3416 sv_magic(sv, 0, 'o', 0, 0);
3417 mg = mg_find(sv, 'o');
3430 if (mg && mg->mg_ptr) {
3432 return mg->mg_ptr + sizeof(PL_collation_ix);
3440 #endif /* USE_LOCALE_COLLATE */
3443 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3448 register STDCHAR rslast;
3449 register STDCHAR *bp;
3453 SV_CHECK_THINKFIRST(sv);
3454 (void)SvUPGRADE(sv, SVt_PV);
3458 if (RsSNARF(PL_rs)) {
3462 else if (RsRECORD(PL_rs)) {
3463 I32 recsize, bytesread;
3466 /* Grab the size of the record we're getting */
3467 recsize = SvIV(SvRV(PL_rs));
3468 (void)SvPOK_only(sv); /* Validate pointer */
3469 buffer = SvGROW(sv, recsize + 1);
3472 /* VMS wants read instead of fread, because fread doesn't respect */
3473 /* RMS record boundaries. This is not necessarily a good thing to be */
3474 /* doing, but we've got no other real choice */
3475 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3477 bytesread = PerlIO_read(fp, buffer, recsize);
3479 SvCUR_set(sv, bytesread);
3480 buffer[bytesread] = '\0';
3481 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3483 else if (RsPARA(PL_rs)) {
3488 rsptr = SvPV(PL_rs, rslen);
3489 rslast = rslen ? rsptr[rslen - 1] : '\0';
3491 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3492 do { /* to make sure file boundaries work right */
3495 i = PerlIO_getc(fp);
3499 PerlIO_ungetc(fp,i);
3505 /* See if we know enough about I/O mechanism to cheat it ! */
3507 /* This used to be #ifdef test - it is made run-time test for ease
3508 of abstracting out stdio interface. One call should be cheap
3509 enough here - and may even be a macro allowing compile
3513 if (PerlIO_fast_gets(fp)) {
3516 * We're going to steal some values from the stdio struct
3517 * and put EVERYTHING in the innermost loop into registers.
3519 register STDCHAR *ptr;
3523 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3524 /* An ungetc()d char is handled separately from the regular
3525 * buffer, so we getc() it back out and stuff it in the buffer.
3527 i = PerlIO_getc(fp);
3528 if (i == EOF) return 0;
3529 *(--((*fp)->_ptr)) = (unsigned char) i;
3533 /* Here is some breathtakingly efficient cheating */
3535 cnt = PerlIO_get_cnt(fp); /* get count into register */
3536 (void)SvPOK_only(sv); /* validate pointer */
3537 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3538 if (cnt > 80 && SvLEN(sv) > append) {
3539 shortbuffered = cnt - SvLEN(sv) + append + 1;
3540 cnt -= shortbuffered;
3544 /* remember that cnt can be negative */
3545 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3550 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3551 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3552 DEBUG_P(PerlIO_printf(Perl_debug_log,
3553 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3554 DEBUG_P(PerlIO_printf(Perl_debug_log,
3555 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3556 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3557 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3562 while (cnt > 0) { /* this | eat */
3564 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3565 goto thats_all_folks; /* screams | sed :-) */
3569 Copy(ptr, bp, cnt, char); /* this | eat */
3570 bp += cnt; /* screams | dust */
3571 ptr += cnt; /* louder | sed :-) */
3576 if (shortbuffered) { /* oh well, must extend */
3577 cnt = shortbuffered;
3579 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3581 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3582 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3586 DEBUG_P(PerlIO_printf(Perl_debug_log,
3587 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3588 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3589 DEBUG_P(PerlIO_printf(Perl_debug_log,
3590 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3591 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3592 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3593 /* This used to call 'filbuf' in stdio form, but as that behaves like
3594 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3595 another abstraction. */
3596 i = PerlIO_getc(fp); /* get more characters */
3597 DEBUG_P(PerlIO_printf(Perl_debug_log,
3598 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3599 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3600 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3601 cnt = PerlIO_get_cnt(fp);
3602 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3603 DEBUG_P(PerlIO_printf(Perl_debug_log,
3604 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3606 if (i == EOF) /* all done for ever? */
3607 goto thats_really_all_folks;
3609 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3611 SvGROW(sv, bpx + cnt + 2);
3612 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3614 *bp++ = i; /* store character from PerlIO_getc */
3616 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3617 goto thats_all_folks;
3621 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3622 memNE((char*)bp - rslen, rsptr, rslen))
3623 goto screamer; /* go back to the fray */
3624 thats_really_all_folks:
3626 cnt += shortbuffered;
3627 DEBUG_P(PerlIO_printf(Perl_debug_log,
3628 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3629 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3630 DEBUG_P(PerlIO_printf(Perl_debug_log,
3631 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3632 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3633 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3635 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3636 DEBUG_P(PerlIO_printf(Perl_debug_log,
3637 "Screamer: done, len=%ld, string=|%.*s|\n",
3638 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3643 /*The big, slow, and stupid way */
3646 /* Need to work around EPOC SDK features */
3647 /* On WINS: MS VC5 generates calls to _chkstk, */
3648 /* if a `large' stack frame is allocated */
3649 /* gcc on MARM does not generate calls like these */
3655 register STDCHAR *bpe = buf + sizeof(buf);
3657 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3658 ; /* keep reading */
3662 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3663 /* Accomodate broken VAXC compiler, which applies U8 cast to
3664 * both args of ?: operator, causing EOF to change into 255
3666 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3670 sv_catpvn(sv, (char *) buf, cnt);
3672 sv_setpvn(sv, (char *) buf, cnt);
3674 if (i != EOF && /* joy */
3676 SvCUR(sv) < rslen ||
3677 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3681 * If we're reading from a TTY and we get a short read,
3682 * indicating that the user hit his EOF character, we need
3683 * to notice it now, because if we try to read from the TTY
3684 * again, the EOF condition will disappear.
3686 * The comparison of cnt to sizeof(buf) is an optimization
3687 * that prevents unnecessary calls to feof().
3691 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3696 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3697 while (i != EOF) { /* to make sure file boundaries work right */
3698 i = PerlIO_getc(fp);
3700 PerlIO_ungetc(fp,i);
3707 win32_strip_return(sv);
3710 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3715 Perl_sv_inc(pTHX_ register SV *sv)
3724 if (SvTHINKFIRST(sv)) {
3725 if (SvREADONLY(sv)) {
3727 if (PL_curcop != &PL_compiling)
3728 Perl_croak(aTHX_ PL_no_modify);
3732 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3739 flags = SvFLAGS(sv);
3740 if (flags & SVp_NOK) {
3741 (void)SvNOK_only(sv);
3745 if (flags & SVp_IOK) {
3747 if (SvUVX(sv) == UV_MAX)
3748 sv_setnv(sv, (NV)UV_MAX + 1.0);
3750 (void)SvIOK_only_UV(sv);
3753 if (SvIVX(sv) == IV_MAX)
3754 sv_setnv(sv, (NV)IV_MAX + 1.0);
3756 (void)SvIOK_only(sv);
3762 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3763 if ((flags & SVTYPEMASK) < SVt_PVNV)
3764 sv_upgrade(sv, SVt_NV);
3766 (void)SvNOK_only(sv);
3770 while (isALPHA(*d)) d++;
3771 while (isDIGIT(*d)) d++;
3773 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
3777 while (d >= SvPVX(sv)) {
3785 /* MKS: The original code here died if letters weren't consecutive.
3786 * at least it didn't have to worry about non-C locales. The
3787 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3788 * arranged in order (although not consecutively) and that only
3789 * [A-Za-z] are accepted by isALPHA in the C locale.
3791 if (*d != 'z' && *d != 'Z') {
3792 do { ++*d; } while (!isALPHA(*d));
3795 *(d--) -= 'z' - 'a';
3800 *(d--) -= 'z' - 'a' + 1;
3804 /* oh,oh, the number grew */
3805 SvGROW(sv, SvCUR(sv) + 2);
3807 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3816 Perl_sv_dec(pTHX_ register SV *sv)
3824 if (SvTHINKFIRST(sv)) {
3825 if (SvREADONLY(sv)) {
3827 if (PL_curcop != &PL_compiling)
3828 Perl_croak(aTHX_ PL_no_modify);
3832 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3839 flags = SvFLAGS(sv);
3840 if (flags & SVp_NOK) {
3842 (void)SvNOK_only(sv);
3845 if (flags & SVp_IOK) {
3847 if (SvUVX(sv) == 0) {
3848 (void)SvIOK_only(sv);
3852 (void)SvIOK_only_UV(sv);
3856 if (SvIVX(sv) == IV_MIN)
3857 sv_setnv(sv, (NV)IV_MIN - 1.0);
3859 (void)SvIOK_only(sv);
3865 if (!(flags & SVp_POK)) {
3866 if ((flags & SVTYPEMASK) < SVt_PVNV)
3867 sv_upgrade(sv, SVt_NV);
3869 (void)SvNOK_only(sv);
3872 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
3875 /* Make a string that will exist for the duration of the expression
3876 * evaluation. Actually, it may have to last longer than that, but
3877 * hopefully we won't free it until it has been assigned to a
3878 * permanent location. */
3881 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3887 sv_setsv(sv,oldstr);
3889 PL_tmps_stack[++PL_tmps_ix] = sv;
3895 Perl_sv_newmortal(pTHX)
3901 SvFLAGS(sv) = SVs_TEMP;
3903 PL_tmps_stack[++PL_tmps_ix] = sv;
3907 /* same thing without the copying */
3910 Perl_sv_2mortal(pTHX_ register SV *sv)
3915 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3918 PL_tmps_stack[++PL_tmps_ix] = sv;
3924 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3931 sv_setpvn(sv,s,len);
3936 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3941 sv_setpvn(sv,s,len);
3945 #if defined(PERL_IMPLICIT_CONTEXT)
3947 Perl_newSVpvf_nocontext(const char* pat, ...)
3954 va_start(args, pat);
3955 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3962 Perl_newSVpvf(pTHX_ const char* pat, ...)
3968 va_start(args, pat);
3969 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3975 Perl_newSVnv(pTHX_ NV n)
3985 Perl_newSViv(pTHX_ IV i)
3995 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4001 sv_upgrade(sv, SVt_RV);
4009 Perl_newRV(pTHX_ SV *tmpRef)
4011 return newRV_noinc(SvREFCNT_inc(tmpRef));
4014 /* make an exact duplicate of old */
4017 Perl_newSVsv(pTHX_ register SV *old)
4024 if (SvTYPE(old) == SVTYPEMASK) {
4025 if (ckWARN_d(WARN_INTERNAL))
4026 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4041 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4054 if (!*s) { /* reset ?? searches */
4055 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4056 pm->op_pmdynflags &= ~PMdf_USED;
4061 /* reset variables */
4063 if (!HvARRAY(stash))
4066 Zero(todo, 256, char);
4073 for ( ; i <= max; i++) {
4076 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4077 for (entry = HvARRAY(stash)[i];
4079 entry = HeNEXT(entry))
4081 if (!todo[(U8)*HeKEY(entry)])
4083 gv = (GV*)HeVAL(entry);
4085 if (SvTHINKFIRST(sv)) {
4086 if (!SvREADONLY(sv) && SvROK(sv))
4091 if (SvTYPE(sv) >= SVt_PV) {
4093 if (SvPVX(sv) != Nullch)
4100 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4102 #ifndef VMS /* VMS has no environ array */
4104 environ[0] = Nullch;
4113 Perl_sv_2io(pTHX_ SV *sv)
4119 switch (SvTYPE(sv)) {
4127 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4131 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4133 return sv_2io(SvRV(sv));
4134 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4140 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4147 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4154 return *gvp = Nullgv, Nullcv;
4155 switch (SvTYPE(sv)) {
4175 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4176 tryAMAGICunDEREF(to_cv);
4179 if (SvTYPE(sv) == SVt_PVCV) {
4188 Perl_croak(aTHX_ "Not a subroutine reference");
4193 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4199 if (lref && !GvCVu(gv)) {
4202 tmpsv = NEWSV(704,0);
4203 gv_efullname3(tmpsv, gv, Nullch);
4204 /* XXX this is probably not what they think they're getting.
4205 * It has the same effect as "sub name;", i.e. just a forward
4207 newSUB(start_subparse(FALSE, 0),
4208 newSVOP(OP_CONST, 0, tmpsv),
4213 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4220 Perl_sv_true(pTHX_ register SV *sv)
4227 if ((tXpv = (XPV*)SvANY(sv)) &&
4228 (*tXpv->xpv_pv > '0' ||
4229 tXpv->xpv_cur > 1 ||
4230 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4237 return SvIVX(sv) != 0;
4240 return SvNVX(sv) != 0.0;
4242 return sv_2bool(sv);
4248 Perl_sv_iv(pTHX_ register SV *sv)
4252 return (IV)SvUVX(sv);
4259 Perl_sv_uv(pTHX_ register SV *sv)
4264 return (UV)SvIVX(sv);
4270 Perl_sv_nv(pTHX_ register SV *sv)
4278 Perl_sv_pv(pTHX_ SV *sv)
4285 return sv_2pv(sv, &n_a);
4289 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4295 return sv_2pv(sv, lp);
4299 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4303 if (SvTHINKFIRST(sv) && !SvROK(sv))
4304 sv_force_normal(sv);
4310 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4312 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4313 PL_op_name[PL_op->op_type]);
4317 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4322 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4323 SvGROW(sv, len + 1);
4324 Move(s,SvPVX(sv),len,char);
4329 SvPOK_on(sv); /* validate pointer */
4331 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4332 (unsigned long)sv,SvPVX(sv)));
4339 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4341 if (ob && SvOBJECT(sv))
4342 return HvNAME(SvSTASH(sv));
4344 switch (SvTYPE(sv)) {
4358 case SVt_PVLV: return "LVALUE";
4359 case SVt_PVAV: return "ARRAY";
4360 case SVt_PVHV: return "HASH";
4361 case SVt_PVCV: return "CODE";
4362 case SVt_PVGV: return "GLOB";
4363 case SVt_PVFM: return "FORMAT";
4364 default: return "UNKNOWN";
4370 Perl_sv_isobject(pTHX_ SV *sv)
4385 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4397 return strEQ(HvNAME(SvSTASH(sv)), name);
4401 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4408 SV_CHECK_THINKFIRST(rv);
4411 if (SvTYPE(rv) < SVt_RV)
4412 sv_upgrade(rv, SVt_RV);
4419 HV* stash = gv_stashpv(classname, TRUE);
4420 (void)sv_bless(rv, stash);
4426 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4429 sv_setsv(rv, &PL_sv_undef);
4433 sv_setiv(newSVrv(rv,classname), (IV)pv);
4438 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4440 sv_setiv(newSVrv(rv,classname), iv);
4445 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4447 sv_setnv(newSVrv(rv,classname), nv);
4452 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4454 sv_setpvn(newSVrv(rv,classname), pv, n);
4459 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4464 Perl_croak(aTHX_ "Can't bless non-reference value");
4466 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4467 if (SvREADONLY(tmpRef))
4468 Perl_croak(aTHX_ PL_no_modify);
4469 if (SvOBJECT(tmpRef)) {
4470 if (SvTYPE(tmpRef) != SVt_PVIO)
4472 SvREFCNT_dec(SvSTASH(tmpRef));
4475 SvOBJECT_on(tmpRef);
4476 if (SvTYPE(tmpRef) != SVt_PVIO)
4478 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4479 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4490 S_sv_unglob(pTHX_ SV *sv)
4492 assert(SvTYPE(sv) == SVt_PVGV);
4497 SvREFCNT_dec(GvSTASH(sv));
4498 GvSTASH(sv) = Nullhv;
4500 sv_unmagic(sv, '*');
4501 Safefree(GvNAME(sv));
4503 SvFLAGS(sv) &= ~SVTYPEMASK;
4504 SvFLAGS(sv) |= SVt_PVMG;
4508 Perl_sv_unref(pTHX_ SV *sv)
4512 if (SvWEAKREF(sv)) {
4520 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4523 sv_2mortal(rv); /* Schedule for freeing later */
4527 Perl_sv_taint(pTHX_ SV *sv)
4529 sv_magic((sv), Nullsv, 't', Nullch, 0);
4533 Perl_sv_untaint(pTHX_ SV *sv)
4535 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4536 MAGIC *mg = mg_find(sv, 't');
4543 Perl_sv_tainted(pTHX_ SV *sv)
4545 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4546 MAGIC *mg = mg_find(sv, 't');
4547 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4554 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4556 char buf[TYPE_CHARS(UV)];
4558 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4560 sv_setpvn(sv, ptr, ebuf - ptr);
4565 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4567 char buf[TYPE_CHARS(UV)];
4569 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4571 sv_setpvn(sv, ptr, ebuf - ptr);
4575 #if defined(PERL_IMPLICIT_CONTEXT)
4577 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4581 va_start(args, pat);
4582 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4588 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4592 va_start(args, pat);
4593 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4600 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4603 va_start(args, pat);
4604 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4610 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4613 va_start(args, pat);
4614 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4619 #if defined(PERL_IMPLICIT_CONTEXT)
4621 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4625 va_start(args, pat);
4626 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4631 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4635 va_start(args, pat);
4636 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4643 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4646 va_start(args, pat);
4647 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4652 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4655 va_start(args, pat);
4656 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4662 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4664 sv_setpvn(sv, "", 0);
4665 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4669 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4677 static char nullstr[] = "(null)";
4679 /* no matter what, this is a string now */
4680 (void)SvPV_force(sv, origlen);
4682 /* special-case "", "%s", and "%_" */
4685 if (patlen == 2 && pat[0] == '%') {
4689 char *s = va_arg(*args, char*);
4690 sv_catpv(sv, s ? s : nullstr);
4692 else if (svix < svmax)
4693 sv_catsv(sv, *svargs);
4697 sv_catsv(sv, va_arg(*args, SV*));
4700 /* See comment on '_' below */
4705 patend = (char*)pat + patlen;
4706 for (p = (char*)pat; p < patend; p = q) {
4714 bool has_precis = FALSE;
4719 STRLEN esignlen = 0;
4721 char *eptr = Nullch;
4723 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4734 for (q = p; q < patend && *q != '%'; ++q) ;
4736 sv_catpvn(sv, p, q - p);
4774 case '1': case '2': case '3':
4775 case '4': case '5': case '6':
4776 case '7': case '8': case '9':
4779 width = width * 10 + (*q++ - '0');
4784 i = va_arg(*args, int);
4786 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4788 width = (i < 0) ? -i : i;
4799 i = va_arg(*args, int);
4801 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4802 precis = (i < 0) ? 0 : i;
4808 precis = precis * 10 + (*q++ - '0');
4817 #if 0 /* when quads have better support within Perl */
4818 if (*(q + 1) == 'l') {
4845 uv = va_arg(*args, int);
4847 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4849 eptr = (char*)utf8buf;
4850 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4854 c = va_arg(*args, int);
4856 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4863 eptr = va_arg(*args, char*);
4865 elen = strlen(eptr);
4868 elen = sizeof nullstr - 1;
4871 else if (svix < svmax) {
4872 eptr = SvPVx(svargs[svix++], elen);
4874 if (has_precis && precis < elen) {
4876 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4879 if (width) { /* fudge width (can't fudge elen) */
4880 width += elen - sv_len_utf8(svargs[svix - 1]);
4888 * The "%_" hack might have to be changed someday,
4889 * if ISO or ANSI decide to use '_' for something.
4890 * So we keep it hidden from users' code.
4894 eptr = SvPVx(va_arg(*args, SV*), elen);
4897 if (has_precis && elen > precis)
4905 uv = (UV)va_arg(*args, void*);
4907 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4918 case 'h': iv = (short)va_arg(*args, int); break;
4919 default: iv = va_arg(*args, int); break;
4920 case 'l': iv = va_arg(*args, long); break;
4921 case 'V': iv = va_arg(*args, IV); break;
4925 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4927 case 'h': iv = (short)iv; break;
4928 default: iv = (int)iv; break;
4929 case 'l': iv = (long)iv; break;
4936 esignbuf[esignlen++] = plus;
4940 esignbuf[esignlen++] = '-';
4970 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4971 default: uv = va_arg(*args, unsigned); break;
4972 case 'l': uv = va_arg(*args, unsigned long); break;
4973 case 'V': uv = va_arg(*args, UV); break;
4977 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4979 case 'h': uv = (unsigned short)uv; break;
4980 default: uv = (unsigned)uv; break;
4981 case 'l': uv = (unsigned long)uv; break;
4987 eptr = ebuf + sizeof ebuf;
4993 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
4999 esignbuf[esignlen++] = '0';
5000 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5006 *--eptr = '0' + dig;
5008 if (alt && *eptr != '0')
5014 *--eptr = '0' + dig;
5016 if (alt && *eptr != '0')
5019 default: /* it had better be ten or less */
5022 *--eptr = '0' + dig;
5023 } while (uv /= base);
5026 elen = (ebuf + sizeof ebuf) - eptr;
5029 zeros = precis - elen;
5030 else if (precis == 0 && elen == 1 && *eptr == '0')
5035 /* FLOATING POINT */
5038 c = 'f'; /* maybe %F isn't supported here */
5044 /* This is evil, but floating point is even more evil */
5047 nv = va_arg(*args, NV);
5049 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5052 if (c != 'e' && c != 'E') {
5054 (void)frexp(nv, &i);
5055 if (i == PERL_INT_MIN)
5056 Perl_die(aTHX_ "panic: frexp");
5058 need = BIT_DIGITS(i);
5060 need += has_precis ? precis : 6; /* known default */
5064 need += 20; /* fudge factor */
5065 if (PL_efloatsize < need) {
5066 Safefree(PL_efloatbuf);
5067 PL_efloatsize = need + 20; /* more fudge */
5068 New(906, PL_efloatbuf, PL_efloatsize, char);
5071 eptr = ebuf + sizeof ebuf;
5074 #ifdef USE_LONG_DOUBLE
5079 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5084 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5097 RESTORE_NUMERIC_STANDARD();
5098 (void)sprintf(PL_efloatbuf, eptr, nv);
5099 RESTORE_NUMERIC_LOCAL();
5102 eptr = PL_efloatbuf;
5103 elen = strlen(PL_efloatbuf);
5107 * User-defined locales may include arbitrary characters.
5108 * And, unfortunately, some system may alloc the "C" locale
5109 * to be overridden by a malicious user.
5112 *used_locale = TRUE;
5113 #endif /* LC_NUMERIC */
5120 i = SvCUR(sv) - origlen;
5123 case 'h': *(va_arg(*args, short*)) = i; break;
5124 default: *(va_arg(*args, int*)) = i; break;
5125 case 'l': *(va_arg(*args, long*)) = i; break;
5126 case 'V': *(va_arg(*args, IV*)) = i; break;
5129 else if (svix < svmax)
5130 sv_setuv(svargs[svix++], (UV)i);
5131 continue; /* not "break" */
5137 if (!args && ckWARN(WARN_PRINTF) &&
5138 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5139 SV *msg = sv_newmortal();
5140 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5141 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5143 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5146 sv_catpv(msg, "end of string");
5147 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5150 /* output mangled stuff ... */
5156 /* ... right here, because formatting flags should not apply */
5157 SvGROW(sv, SvCUR(sv) + elen + 1);
5159 memcpy(p, eptr, elen);
5162 SvCUR(sv) = p - SvPVX(sv);
5163 continue; /* not "break" */
5166 have = esignlen + zeros + elen;
5167 need = (have > width ? have : width);
5170 SvGROW(sv, SvCUR(sv) + need + 1);
5172 if (esignlen && fill == '0') {
5173 for (i = 0; i < esignlen; i++)
5177 memset(p, fill, gap);
5180 if (esignlen && fill != '0') {
5181 for (i = 0; i < esignlen; i++)
5185 for (i = zeros; i; i--)
5189 memcpy(p, eptr, elen);
5193 memset(p, ' ', gap);
5197 SvCUR(sv) = p - SvPVX(sv);
5208 do_report_used(pTHXo_ SV *sv)
5210 if (SvTYPE(sv) != SVTYPEMASK) {
5211 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
5212 PerlIO_printf(PerlIO_stderr(), "****\n");
5218 do_clean_objs(pTHXo_ SV *sv)
5222 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5223 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
5229 /* XXX Might want to check arrays, etc. */
5232 #ifndef DISABLE_DESTRUCTOR_KLUDGE
5234 do_clean_named_objs(pTHXo_ SV *sv)
5236 if (SvTYPE(sv) == SVt_PVGV) {
5237 if ( SvOBJECT(GvSV(sv)) ||
5238 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
5239 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
5240 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
5241 GvCV(sv) && SvOBJECT(GvCV(sv)) )
5243 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
5251 do_clean_all(pTHXo_ SV *sv)
5253 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
5254 SvFLAGS(sv) |= SVf_BREAK;