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, ...)
3952 va_start(args, pat);
3953 sv = vnewSVpvf(pat, &args);
3960 Perl_newSVpvf(pTHX_ const char* pat, ...)
3964 va_start(args, pat);
3965 sv = vnewSVpvf(pat, &args);
3971 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
3975 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
3980 Perl_newSVnv(pTHX_ NV n)
3990 Perl_newSViv(pTHX_ IV i)
4000 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4006 sv_upgrade(sv, SVt_RV);
4014 Perl_newRV(pTHX_ SV *tmpRef)
4016 return newRV_noinc(SvREFCNT_inc(tmpRef));
4019 /* make an exact duplicate of old */
4022 Perl_newSVsv(pTHX_ register SV *old)
4029 if (SvTYPE(old) == SVTYPEMASK) {
4030 if (ckWARN_d(WARN_INTERNAL))
4031 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4046 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4059 if (!*s) { /* reset ?? searches */
4060 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4061 pm->op_pmdynflags &= ~PMdf_USED;
4066 /* reset variables */
4068 if (!HvARRAY(stash))
4071 Zero(todo, 256, char);
4078 for ( ; i <= max; i++) {
4081 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4082 for (entry = HvARRAY(stash)[i];
4084 entry = HeNEXT(entry))
4086 if (!todo[(U8)*HeKEY(entry)])
4088 gv = (GV*)HeVAL(entry);
4090 if (SvTHINKFIRST(sv)) {
4091 if (!SvREADONLY(sv) && SvROK(sv))
4096 if (SvTYPE(sv) >= SVt_PV) {
4098 if (SvPVX(sv) != Nullch)
4105 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4107 #ifndef VMS /* VMS has no environ array */
4109 environ[0] = Nullch;
4118 Perl_sv_2io(pTHX_ SV *sv)
4124 switch (SvTYPE(sv)) {
4132 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4136 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4138 return sv_2io(SvRV(sv));
4139 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4145 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4152 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4159 return *gvp = Nullgv, Nullcv;
4160 switch (SvTYPE(sv)) {
4180 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4181 tryAMAGICunDEREF(to_cv);
4184 if (SvTYPE(sv) == SVt_PVCV) {
4193 Perl_croak(aTHX_ "Not a subroutine reference");
4198 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4204 if (lref && !GvCVu(gv)) {
4207 tmpsv = NEWSV(704,0);
4208 gv_efullname3(tmpsv, gv, Nullch);
4209 /* XXX this is probably not what they think they're getting.
4210 * It has the same effect as "sub name;", i.e. just a forward
4212 newSUB(start_subparse(FALSE, 0),
4213 newSVOP(OP_CONST, 0, tmpsv),
4218 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4225 Perl_sv_true(pTHX_ register SV *sv)
4232 if ((tXpv = (XPV*)SvANY(sv)) &&
4233 (*tXpv->xpv_pv > '0' ||
4234 tXpv->xpv_cur > 1 ||
4235 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4242 return SvIVX(sv) != 0;
4245 return SvNVX(sv) != 0.0;
4247 return sv_2bool(sv);
4253 Perl_sv_iv(pTHX_ register SV *sv)
4257 return (IV)SvUVX(sv);
4264 Perl_sv_uv(pTHX_ register SV *sv)
4269 return (UV)SvIVX(sv);
4275 Perl_sv_nv(pTHX_ register SV *sv)
4283 Perl_sv_pv(pTHX_ SV *sv)
4290 return sv_2pv(sv, &n_a);
4294 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4300 return sv_2pv(sv, lp);
4304 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4308 if (SvTHINKFIRST(sv) && !SvROK(sv))
4309 sv_force_normal(sv);
4315 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4317 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4318 PL_op_name[PL_op->op_type]);
4322 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4327 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4328 SvGROW(sv, len + 1);
4329 Move(s,SvPVX(sv),len,char);
4334 SvPOK_on(sv); /* validate pointer */
4336 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4337 (unsigned long)sv,SvPVX(sv)));
4344 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4346 if (ob && SvOBJECT(sv))
4347 return HvNAME(SvSTASH(sv));
4349 switch (SvTYPE(sv)) {
4363 case SVt_PVLV: return "LVALUE";
4364 case SVt_PVAV: return "ARRAY";
4365 case SVt_PVHV: return "HASH";
4366 case SVt_PVCV: return "CODE";
4367 case SVt_PVGV: return "GLOB";
4368 case SVt_PVFM: return "FORMAT";
4369 default: return "UNKNOWN";
4375 Perl_sv_isobject(pTHX_ SV *sv)
4390 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4402 return strEQ(HvNAME(SvSTASH(sv)), name);
4406 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4413 SV_CHECK_THINKFIRST(rv);
4416 if (SvTYPE(rv) < SVt_RV)
4417 sv_upgrade(rv, SVt_RV);
4424 HV* stash = gv_stashpv(classname, TRUE);
4425 (void)sv_bless(rv, stash);
4431 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4434 sv_setsv(rv, &PL_sv_undef);
4438 sv_setiv(newSVrv(rv,classname), (IV)pv);
4443 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4445 sv_setiv(newSVrv(rv,classname), iv);
4450 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4452 sv_setnv(newSVrv(rv,classname), nv);
4457 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4459 sv_setpvn(newSVrv(rv,classname), pv, n);
4464 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4469 Perl_croak(aTHX_ "Can't bless non-reference value");
4471 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4472 if (SvREADONLY(tmpRef))
4473 Perl_croak(aTHX_ PL_no_modify);
4474 if (SvOBJECT(tmpRef)) {
4475 if (SvTYPE(tmpRef) != SVt_PVIO)
4477 SvREFCNT_dec(SvSTASH(tmpRef));
4480 SvOBJECT_on(tmpRef);
4481 if (SvTYPE(tmpRef) != SVt_PVIO)
4483 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4484 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4495 S_sv_unglob(pTHX_ SV *sv)
4497 assert(SvTYPE(sv) == SVt_PVGV);
4502 SvREFCNT_dec(GvSTASH(sv));
4503 GvSTASH(sv) = Nullhv;
4505 sv_unmagic(sv, '*');
4506 Safefree(GvNAME(sv));
4508 SvFLAGS(sv) &= ~SVTYPEMASK;
4509 SvFLAGS(sv) |= SVt_PVMG;
4513 Perl_sv_unref(pTHX_ SV *sv)
4517 if (SvWEAKREF(sv)) {
4525 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4528 sv_2mortal(rv); /* Schedule for freeing later */
4532 Perl_sv_taint(pTHX_ SV *sv)
4534 sv_magic((sv), Nullsv, 't', Nullch, 0);
4538 Perl_sv_untaint(pTHX_ SV *sv)
4540 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4541 MAGIC *mg = mg_find(sv, 't');
4548 Perl_sv_tainted(pTHX_ SV *sv)
4550 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4551 MAGIC *mg = mg_find(sv, 't');
4552 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4559 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4561 char buf[TYPE_CHARS(UV)];
4563 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4565 sv_setpvn(sv, ptr, ebuf - ptr);
4570 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4572 char buf[TYPE_CHARS(UV)];
4574 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4576 sv_setpvn(sv, ptr, ebuf - ptr);
4580 #if defined(PERL_IMPLICIT_CONTEXT)
4582 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4586 va_start(args, pat);
4587 sv_vsetpvf(sv, pat, &args);
4593 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4597 va_start(args, pat);
4598 sv_vsetpvf_mg(sv, pat, &args);
4604 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4607 va_start(args, pat);
4608 sv_vsetpvf(sv, pat, &args);
4613 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4615 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4619 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4622 va_start(args, pat);
4623 sv_vsetpvf_mg(sv, pat, &args);
4628 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4630 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4634 #if defined(PERL_IMPLICIT_CONTEXT)
4636 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4640 va_start(args, pat);
4641 sv_vcatpvf(sv, pat, &args);
4646 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4650 va_start(args, pat);
4651 sv_vcatpvf_mg(sv, pat, &args);
4657 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4660 va_start(args, pat);
4661 sv_vcatpvf(sv, pat, &args);
4666 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4668 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4672 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4675 va_start(args, pat);
4676 sv_vcatpvf_mg(sv, pat, &args);
4681 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4683 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4688 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4690 sv_setpvn(sv, "", 0);
4691 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4695 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4703 static char nullstr[] = "(null)";
4705 /* no matter what, this is a string now */
4706 (void)SvPV_force(sv, origlen);
4708 /* special-case "", "%s", and "%_" */
4711 if (patlen == 2 && pat[0] == '%') {
4715 char *s = va_arg(*args, char*);
4716 sv_catpv(sv, s ? s : nullstr);
4718 else if (svix < svmax)
4719 sv_catsv(sv, *svargs);
4723 sv_catsv(sv, va_arg(*args, SV*));
4726 /* See comment on '_' below */
4731 patend = (char*)pat + patlen;
4732 for (p = (char*)pat; p < patend; p = q) {
4740 bool has_precis = FALSE;
4745 STRLEN esignlen = 0;
4747 char *eptr = Nullch;
4749 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4760 for (q = p; q < patend && *q != '%'; ++q) ;
4762 sv_catpvn(sv, p, q - p);
4800 case '1': case '2': case '3':
4801 case '4': case '5': case '6':
4802 case '7': case '8': case '9':
4805 width = width * 10 + (*q++ - '0');
4810 i = va_arg(*args, int);
4812 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4814 width = (i < 0) ? -i : i;
4825 i = va_arg(*args, int);
4827 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4828 precis = (i < 0) ? 0 : i;
4834 precis = precis * 10 + (*q++ - '0');
4843 #if 0 /* when quads have better support within Perl */
4844 if (*(q + 1) == 'l') {
4871 uv = va_arg(*args, int);
4873 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4875 eptr = (char*)utf8buf;
4876 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4880 c = va_arg(*args, int);
4882 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4889 eptr = va_arg(*args, char*);
4891 elen = strlen(eptr);
4894 elen = sizeof nullstr - 1;
4897 else if (svix < svmax) {
4898 eptr = SvPVx(svargs[svix++], elen);
4900 if (has_precis && precis < elen) {
4902 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4905 if (width) { /* fudge width (can't fudge elen) */
4906 width += elen - sv_len_utf8(svargs[svix - 1]);
4914 * The "%_" hack might have to be changed someday,
4915 * if ISO or ANSI decide to use '_' for something.
4916 * So we keep it hidden from users' code.
4920 eptr = SvPVx(va_arg(*args, SV*), elen);
4923 if (has_precis && elen > precis)
4931 uv = (UV)va_arg(*args, void*);
4933 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4944 case 'h': iv = (short)va_arg(*args, int); break;
4945 default: iv = va_arg(*args, int); break;
4946 case 'l': iv = va_arg(*args, long); break;
4947 case 'V': iv = va_arg(*args, IV); break;
4951 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4953 case 'h': iv = (short)iv; break;
4954 default: iv = (int)iv; break;
4955 case 'l': iv = (long)iv; break;
4962 esignbuf[esignlen++] = plus;
4966 esignbuf[esignlen++] = '-';
4996 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4997 default: uv = va_arg(*args, unsigned); break;
4998 case 'l': uv = va_arg(*args, unsigned long); break;
4999 case 'V': uv = va_arg(*args, UV); break;
5003 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5005 case 'h': uv = (unsigned short)uv; break;
5006 default: uv = (unsigned)uv; break;
5007 case 'l': uv = (unsigned long)uv; break;
5013 eptr = ebuf + sizeof ebuf;
5019 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5025 esignbuf[esignlen++] = '0';
5026 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5032 *--eptr = '0' + dig;
5034 if (alt && *eptr != '0')
5040 *--eptr = '0' + dig;
5042 if (alt && *eptr != '0')
5045 default: /* it had better be ten or less */
5048 *--eptr = '0' + dig;
5049 } while (uv /= base);
5052 elen = (ebuf + sizeof ebuf) - eptr;
5055 zeros = precis - elen;
5056 else if (precis == 0 && elen == 1 && *eptr == '0')
5061 /* FLOATING POINT */
5064 c = 'f'; /* maybe %F isn't supported here */
5070 /* This is evil, but floating point is even more evil */
5073 nv = va_arg(*args, NV);
5075 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5078 if (c != 'e' && c != 'E') {
5080 (void)frexp(nv, &i);
5081 if (i == PERL_INT_MIN)
5082 Perl_die(aTHX_ "panic: frexp");
5084 need = BIT_DIGITS(i);
5086 need += has_precis ? precis : 6; /* known default */
5090 need += 20; /* fudge factor */
5091 if (PL_efloatsize < need) {
5092 Safefree(PL_efloatbuf);
5093 PL_efloatsize = need + 20; /* more fudge */
5094 New(906, PL_efloatbuf, PL_efloatsize, char);
5097 eptr = ebuf + sizeof ebuf;
5100 #ifdef USE_LONG_DOUBLE
5105 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5110 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5123 RESTORE_NUMERIC_STANDARD();
5124 (void)sprintf(PL_efloatbuf, eptr, nv);
5125 RESTORE_NUMERIC_LOCAL();
5128 eptr = PL_efloatbuf;
5129 elen = strlen(PL_efloatbuf);
5133 * User-defined locales may include arbitrary characters.
5134 * And, unfortunately, some system may alloc the "C" locale
5135 * to be overridden by a malicious user.
5138 *used_locale = TRUE;
5139 #endif /* LC_NUMERIC */
5146 i = SvCUR(sv) - origlen;
5149 case 'h': *(va_arg(*args, short*)) = i; break;
5150 default: *(va_arg(*args, int*)) = i; break;
5151 case 'l': *(va_arg(*args, long*)) = i; break;
5152 case 'V': *(va_arg(*args, IV*)) = i; break;
5155 else if (svix < svmax)
5156 sv_setuv(svargs[svix++], (UV)i);
5157 continue; /* not "break" */
5163 if (!args && ckWARN(WARN_PRINTF) &&
5164 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5165 SV *msg = sv_newmortal();
5166 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5167 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5169 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5172 sv_catpv(msg, "end of string");
5173 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5176 /* output mangled stuff ... */
5182 /* ... right here, because formatting flags should not apply */
5183 SvGROW(sv, SvCUR(sv) + elen + 1);
5185 memcpy(p, eptr, elen);
5188 SvCUR(sv) = p - SvPVX(sv);
5189 continue; /* not "break" */
5192 have = esignlen + zeros + elen;
5193 need = (have > width ? have : width);
5196 SvGROW(sv, SvCUR(sv) + need + 1);
5198 if (esignlen && fill == '0') {
5199 for (i = 0; i < esignlen; i++)
5203 memset(p, fill, gap);
5206 if (esignlen && fill != '0') {
5207 for (i = 0; i < esignlen; i++)
5211 for (i = zeros; i; i--)
5215 memcpy(p, eptr, elen);
5219 memset(p, ' ', gap);
5223 SvCUR(sv) = p - SvPVX(sv);
5234 do_report_used(pTHXo_ SV *sv)
5236 if (SvTYPE(sv) != SVTYPEMASK) {
5237 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
5238 PerlIO_printf(PerlIO_stderr(), "****\n");
5244 do_clean_objs(pTHXo_ SV *sv)
5248 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5249 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
5255 /* XXX Might want to check arrays, etc. */
5258 #ifndef DISABLE_DESTRUCTOR_KLUDGE
5260 do_clean_named_objs(pTHXo_ SV *sv)
5262 if (SvTYPE(sv) == SVt_PVGV) {
5263 if ( SvOBJECT(GvSV(sv)) ||
5264 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
5265 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
5266 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
5267 GvCV(sv) && SvOBJECT(GvCV(sv)) )
5269 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
5277 do_clean_all(pTHXo_ SV *sv)
5279 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
5280 SvFLAGS(sv) |= SVf_BREAK;