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(do_report_used);
301 Perl_sv_clean_objs(pTHX)
303 PL_in_clean_objs = TRUE;
304 visit(do_clean_objs);
305 #ifndef DISABLE_DESTRUCTOR_KLUDGE
306 /* some barnacles may yet remain, clinging to typeglobs */
307 visit(do_clean_named_objs);
309 PL_in_clean_objs = FALSE;
313 Perl_sv_clean_all(pTHX)
315 PL_in_clean_all = TRUE;
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() or atoll() */
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) && !SvOK(sv)) {
1112 if (ckWARN(WARN_UNINITIALIZED))
1113 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1119 return (IV)(SvUVX(sv));
1126 /* We can cache the IV/UV value even if it not good enough
1127 * to reconstruct NV, since the conversion to PV will prefer
1131 if (SvTYPE(sv) == SVt_NV)
1132 sv_upgrade(sv, SVt_PVNV);
1135 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1136 SvIVX(sv) = I_V(SvNVX(sv));
1138 SvUVX(sv) = U_V(SvNVX(sv));
1142 DEBUG_c(PerlIO_printf(Perl_debug_log,
1143 "0x%" PERL_PRIx64 " 2iv(%" PERL_PRIu64 " => %" PERL_PRId64 ") (as unsigned)\n",
1145 (UV)SvUVX(sv), (IV)SvUVX(sv)));
1147 DEBUG_c(PerlIO_printf(Perl_debug_log,
1148 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1150 (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(%" PERL_PRIgldbl ")\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));
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) && !SvOK(sv)) {
1257 if (ckWARN(WARN_UNINITIALIZED))
1258 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1267 return (UV)SvIVX(sv);
1271 /* We can cache the IV/UV value even if it not good enough
1272 * to reconstruct NV, since the conversion to PV will prefer
1275 if (SvTYPE(sv) == SVt_NV)
1276 sv_upgrade(sv, SVt_PVNV);
1278 if (SvNVX(sv) >= -0.5) {
1280 SvUVX(sv) = U_V(SvNVX(sv));
1283 SvIVX(sv) = I_V(SvNVX(sv));
1286 DEBUG_c(PerlIO_printf(Perl_debug_log,
1287 "0x%" PERL_PRIx64 " 2uv(%" PERL_PRId64 " => %" PERL_PRIu64 ") (as signed)\n",
1288 (unsigned long)sv,(long)SvIVX(sv),
1289 (long)(UV)SvIVX(sv)));
1291 DEBUG_c(PerlIO_printf(Perl_debug_log,
1292 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1293 (unsigned long)sv,(long)SvIVX(sv),
1294 (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));
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(%" PERL_PRIg64 ")\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));
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);
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));
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) && !SvOK(sv)) {
1428 if (ckWARN(WARN_UNINITIALIZED))
1429 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1433 if (SvTYPE(sv) < SVt_NV) {
1434 if (SvTYPE(sv) == SVt_IV)
1435 sv_upgrade(sv, SVt_PVNV);
1437 sv_upgrade(sv, SVt_NV);
1438 #if defined(USE_LONG_DOUBLE)
1440 RESTORE_NUMERIC_STANDARD();
1441 PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIg64 ")\n",
1442 (unsigned long)sv, SvNVX(sv));
1443 RESTORE_NUMERIC_LOCAL();
1447 RESTORE_NUMERIC_STANDARD();
1448 PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
1449 (unsigned long)sv, SvNVX(sv));
1450 RESTORE_NUMERIC_LOCAL();
1454 else if (SvTYPE(sv) < SVt_PVNV)
1455 sv_upgrade(sv, SVt_PVNV);
1457 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1459 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1461 else if (SvPOKp(sv) && SvLEN(sv)) {
1463 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1465 SvNVX(sv) = Atof(SvPVX(sv));
1469 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1470 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1471 if (SvTYPE(sv) < SVt_NV)
1472 /* Typically the caller expects that sv_any is not NULL now. */
1473 sv_upgrade(sv, SVt_NV);
1477 #if defined(USE_LONG_DOUBLE)
1479 RESTORE_NUMERIC_STANDARD();
1480 PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIg64 ")\n",
1481 (unsigned long)sv, SvNVX(sv));
1482 RESTORE_NUMERIC_LOCAL();
1486 RESTORE_NUMERIC_STANDARD();
1487 PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
1488 (unsigned long)sv, SvNVX(sv));
1489 RESTORE_NUMERIC_LOCAL();
1496 S_asIV(pTHX_ SV *sv)
1498 I32 numtype = looks_like_number(sv);
1501 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1502 return Atol(SvPVX(sv));
1505 if (ckWARN(WARN_NUMERIC))
1508 d = Atof(SvPVX(sv));
1513 S_asUV(pTHX_ SV *sv)
1515 I32 numtype = looks_like_number(sv);
1518 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1519 return Strtoul(SvPVX(sv), Null(char**), 10);
1523 if (ckWARN(WARN_NUMERIC))
1526 return U_V(Atof(SvPVX(sv)));
1530 * Returns a combination of (advisory only - can get false negatives)
1531 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1533 * 0 if does not look like number.
1535 * In fact possible values are 0 and
1536 * IS_NUMBER_TO_INT_BY_ATOL 123
1537 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1538 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1539 * with a possible addition of IS_NUMBER_NEG.
1543 Perl_looks_like_number(pTHX_ SV *sv)
1546 register char *send;
1547 register char *sbegin;
1548 register char *nbegin;
1556 else if (SvPOKp(sv))
1557 sbegin = SvPV(sv, len);
1560 send = sbegin + len;
1567 numtype = IS_NUMBER_NEG;
1574 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1575 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1579 /* next must be digit or the radix separator */
1583 } while (isDIGIT(*s));
1585 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1586 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1588 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1591 #ifdef USE_LOCALE_NUMERIC
1592 || IS_NUMERIC_RADIX(*s)
1596 numtype |= IS_NUMBER_NOT_IV;
1597 while (isDIGIT(*s)) /* optional digits after the radix */
1602 #ifdef USE_LOCALE_NUMERIC
1603 || IS_NUMERIC_RADIX(*s)
1607 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1608 /* no digits before the radix means we need digits after it */
1612 } while (isDIGIT(*s));
1620 /* we can have an optional exponent part */
1621 if (*s == 'e' || *s == 'E') {
1622 numtype &= ~IS_NUMBER_NEG;
1623 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1625 if (*s == '+' || *s == '-')
1630 } while (isDIGIT(*s));
1639 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1640 return IS_NUMBER_TO_INT_BY_ATOL;
1645 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1648 return sv_2pv(sv, &n_a);
1651 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1653 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1656 char *ptr = buf + TYPE_CHARS(UV);
1671 *--ptr = '0' + (uv % 10);
1680 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1685 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1686 char *tmpbuf = tbuf;
1692 if (SvGMAGICAL(sv)) {
1701 (void)sprintf(tmpbuf,"%" PERL_PRIu64,(UV)SvUVX(sv));
1703 (void)sprintf(tmpbuf,"%" PERL_PRId64,(IV)SvIVX(sv));
1706 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1708 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1714 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1719 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1721 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1722 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1728 if (SvTHINKFIRST(sv)) {
1731 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1732 return SvPV(tmpstr,*lp);
1739 switch (SvTYPE(sv)) {
1741 if ( ((SvFLAGS(sv) &
1742 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1743 == (SVs_OBJECT|SVs_RMG))
1744 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1745 && (mg = mg_find(sv, 'r'))) {
1747 regexp *re = (regexp *)mg->mg_obj;
1750 char *fptr = "msix";
1755 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1757 while(ch = *fptr++) {
1759 reflags[left++] = ch;
1762 reflags[right--] = ch;
1767 reflags[left] = '-';
1771 mg->mg_len = re->prelen + 4 + left;
1772 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1773 Copy("(?", mg->mg_ptr, 2, char);
1774 Copy(reflags, mg->mg_ptr+2, left, char);
1775 Copy(":", mg->mg_ptr+left+2, 1, char);
1776 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1777 mg->mg_ptr[mg->mg_len - 1] = ')';
1778 mg->mg_ptr[mg->mg_len] = 0;
1780 PL_reginterp_cnt += re->program[0].next_off;
1792 case SVt_PVBM: s = "SCALAR"; break;
1793 case SVt_PVLV: s = "LVALUE"; break;
1794 case SVt_PVAV: s = "ARRAY"; break;
1795 case SVt_PVHV: s = "HASH"; break;
1796 case SVt_PVCV: s = "CODE"; break;
1797 case SVt_PVGV: s = "GLOB"; break;
1798 case SVt_PVFM: s = "FORMAT"; break;
1799 case SVt_PVIO: s = "IO"; break;
1800 default: s = "UNKNOWN"; break;
1804 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1808 Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", (UV)sv);
1810 Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
1817 if (SvREADONLY(sv) && !SvOK(sv)) {
1819 if (ckWARN(WARN_UNINITIALIZED))
1820 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1825 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1826 /* XXXX 64-bit? IV may have better precision... */
1827 if (SvTYPE(sv) < SVt_PVNV)
1828 sv_upgrade(sv, SVt_PVNV);
1831 olderrno = errno; /* some Xenix systems wipe out errno here */
1833 if (SvNVX(sv) == 0.0)
1834 (void)strcpy(s,"0");
1838 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1841 #ifdef FIXNEGATIVEZERO
1842 if (*s == '-' && s[1] == '0' && !s[2])
1851 else if (SvIOKp(sv)) {
1852 U32 isIOK = SvIOK(sv);
1853 U32 isUIOK = SvIsUV(sv);
1854 char buf[TYPE_CHARS(UV)];
1857 if (SvTYPE(sv) < SVt_PVIV)
1858 sv_upgrade(sv, SVt_PVIV);
1860 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1862 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1863 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
1864 Move(ptr,SvPVX(sv),ebuf - ptr,char);
1865 SvCUR_set(sv, ebuf - ptr);
1878 if (ckWARN(WARN_UNINITIALIZED)
1879 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1881 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1884 if (SvTYPE(sv) < SVt_PV)
1885 /* Typically the caller expects that sv_any is not NULL now. */
1886 sv_upgrade(sv, SVt_PV);
1889 *lp = s - SvPVX(sv);
1892 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
1893 (unsigned long)sv,SvPVX(sv)));
1897 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1898 /* Sneaky stuff here */
1902 tsv = newSVpv(tmpbuf, 0);
1918 len = strlen(tmpbuf);
1920 #ifdef FIXNEGATIVEZERO
1921 if (len == 2 && t[0] == '-' && t[1] == '0') {
1926 (void)SvUPGRADE(sv, SVt_PV);
1928 s = SvGROW(sv, len + 1);
1936 /* This function is only called on magical items */
1938 Perl_sv_2bool(pTHX_ register SV *sv)
1948 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1949 return SvTRUE(tmpsv);
1950 return SvRV(sv) != 0;
1953 register XPV* Xpvtmp;
1954 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1955 (*Xpvtmp->xpv_pv > '0' ||
1956 Xpvtmp->xpv_cur > 1 ||
1957 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
1964 return SvIVX(sv) != 0;
1967 return SvNVX(sv) != 0.0;
1974 /* Note: sv_setsv() should not be called with a source string that needs
1975 * to be reused, since it may destroy the source string if it is marked
1980 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
1983 register U32 sflags;
1989 SV_CHECK_THINKFIRST(dstr);
1991 sstr = &PL_sv_undef;
1992 stype = SvTYPE(sstr);
1993 dtype = SvTYPE(dstr);
1997 /* There's a lot of redundancy below but we're going for speed here */
2002 if (dtype != SVt_PVGV) {
2003 (void)SvOK_off(dstr);
2011 sv_upgrade(dstr, SVt_IV);
2014 sv_upgrade(dstr, SVt_PVNV);
2018 sv_upgrade(dstr, SVt_PVIV);
2021 (void)SvIOK_only(dstr);
2022 SvIVX(dstr) = SvIVX(sstr);
2035 sv_upgrade(dstr, SVt_NV);
2040 sv_upgrade(dstr, SVt_PVNV);
2043 SvNVX(dstr) = SvNVX(sstr);
2044 (void)SvNOK_only(dstr);
2052 sv_upgrade(dstr, SVt_RV);
2053 else if (dtype == SVt_PVGV &&
2054 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2057 if (PL_curcop->cop_stash != GvSTASH(dstr))
2058 GvIMPORTED_on(dstr);
2068 sv_upgrade(dstr, SVt_PV);
2071 if (dtype < SVt_PVIV)
2072 sv_upgrade(dstr, SVt_PVIV);
2075 if (dtype < SVt_PVNV)
2076 sv_upgrade(dstr, SVt_PVNV);
2083 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2084 PL_op_name[PL_op->op_type]);
2086 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2090 if (dtype <= SVt_PVGV) {
2092 if (dtype != SVt_PVGV) {
2093 char *name = GvNAME(sstr);
2094 STRLEN len = GvNAMELEN(sstr);
2095 sv_upgrade(dstr, SVt_PVGV);
2096 sv_magic(dstr, dstr, '*', name, len);
2097 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2098 GvNAME(dstr) = savepvn(name, len);
2099 GvNAMELEN(dstr) = len;
2100 SvFAKE_on(dstr); /* can coerce to non-glob */
2102 /* ahem, death to those who redefine active sort subs */
2103 else if (PL_curstackinfo->si_type == PERLSI_SORT
2104 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2105 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2107 (void)SvOK_off(dstr);
2108 GvINTRO_off(dstr); /* one-shot flag */
2110 GvGP(dstr) = gp_ref(GvGP(sstr));
2112 if (PL_curcop->cop_stash != GvSTASH(dstr))
2113 GvIMPORTED_on(dstr);
2120 if (SvGMAGICAL(sstr)) {
2122 if (SvTYPE(sstr) != stype) {
2123 stype = SvTYPE(sstr);
2124 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2128 if (stype == SVt_PVLV)
2129 (void)SvUPGRADE(dstr, SVt_PVNV);
2131 (void)SvUPGRADE(dstr, stype);
2134 sflags = SvFLAGS(sstr);
2136 if (sflags & SVf_ROK) {
2137 if (dtype >= SVt_PV) {
2138 if (dtype == SVt_PVGV) {
2139 SV *sref = SvREFCNT_inc(SvRV(sstr));
2141 int intro = GvINTRO(dstr);
2145 GvGP(dstr)->gp_refcnt--;
2146 GvINTRO_off(dstr); /* one-shot flag */
2147 Newz(602,gp, 1, GP);
2148 GvGP(dstr) = gp_ref(gp);
2149 GvSV(dstr) = NEWSV(72,0);
2150 GvLINE(dstr) = PL_curcop->cop_line;
2151 GvEGV(dstr) = (GV*)dstr;
2154 switch (SvTYPE(sref)) {
2157 SAVESPTR(GvAV(dstr));
2159 dref = (SV*)GvAV(dstr);
2160 GvAV(dstr) = (AV*)sref;
2161 if (PL_curcop->cop_stash != GvSTASH(dstr))
2162 GvIMPORTED_AV_on(dstr);
2166 SAVESPTR(GvHV(dstr));
2168 dref = (SV*)GvHV(dstr);
2169 GvHV(dstr) = (HV*)sref;
2170 if (PL_curcop->cop_stash != GvSTASH(dstr))
2171 GvIMPORTED_HV_on(dstr);
2175 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2176 SvREFCNT_dec(GvCV(dstr));
2177 GvCV(dstr) = Nullcv;
2178 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2179 PL_sub_generation++;
2181 SAVESPTR(GvCV(dstr));
2184 dref = (SV*)GvCV(dstr);
2185 if (GvCV(dstr) != (CV*)sref) {
2186 CV* cv = GvCV(dstr);
2188 if (!GvCVGEN((GV*)dstr) &&
2189 (CvROOT(cv) || CvXSUB(cv)))
2191 SV *const_sv = cv_const_sv(cv);
2192 bool const_changed = TRUE;
2194 const_changed = sv_cmp(const_sv,
2195 op_const_sv(CvSTART((CV*)sref),
2197 /* ahem, death to those who redefine
2198 * active sort subs */
2199 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2200 PL_sortcop == CvSTART(cv))
2202 "Can't redefine active sort subroutine %s",
2203 GvENAME((GV*)dstr));
2204 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2205 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2206 && HvNAME(GvSTASH(CvGV(cv)))
2207 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2209 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2210 "Constant subroutine %s redefined"
2211 : "Subroutine %s redefined",
2212 GvENAME((GV*)dstr));
2215 cv_ckproto(cv, (GV*)dstr,
2216 SvPOK(sref) ? SvPVX(sref) : Nullch);
2218 GvCV(dstr) = (CV*)sref;
2219 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2220 GvASSUMECV_on(dstr);
2221 PL_sub_generation++;
2223 if (PL_curcop->cop_stash != GvSTASH(dstr))
2224 GvIMPORTED_CV_on(dstr);
2228 SAVESPTR(GvIOp(dstr));
2230 dref = (SV*)GvIOp(dstr);
2231 GvIOp(dstr) = (IO*)sref;
2235 SAVESPTR(GvSV(dstr));
2237 dref = (SV*)GvSV(dstr);
2239 if (PL_curcop->cop_stash != GvSTASH(dstr))
2240 GvIMPORTED_SV_on(dstr);
2251 (void)SvOOK_off(dstr); /* backoff */
2253 Safefree(SvPVX(dstr));
2254 SvLEN(dstr)=SvCUR(dstr)=0;
2257 (void)SvOK_off(dstr);
2258 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2260 if (sflags & SVp_NOK) {
2262 SvNVX(dstr) = SvNVX(sstr);
2264 if (sflags & SVp_IOK) {
2265 (void)SvIOK_on(dstr);
2266 SvIVX(dstr) = SvIVX(sstr);
2270 if (SvAMAGIC(sstr)) {
2274 else if (sflags & SVp_POK) {
2277 * Check to see if we can just swipe the string. If so, it's a
2278 * possible small lose on short strings, but a big win on long ones.
2279 * It might even be a win on short strings if SvPVX(dstr)
2280 * has to be allocated and SvPVX(sstr) has to be freed.
2283 if (SvTEMP(sstr) && /* slated for free anyway? */
2284 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2285 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2287 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2289 SvFLAGS(dstr) &= ~SVf_OOK;
2290 Safefree(SvPVX(dstr) - SvIVX(dstr));
2292 else if (SvLEN(dstr))
2293 Safefree(SvPVX(dstr));
2295 (void)SvPOK_only(dstr);
2296 SvPV_set(dstr, SvPVX(sstr));
2297 SvLEN_set(dstr, SvLEN(sstr));
2298 SvCUR_set(dstr, SvCUR(sstr));
2300 (void)SvOK_off(sstr);
2301 SvPV_set(sstr, Nullch);
2306 else { /* have to copy actual string */
2307 STRLEN len = SvCUR(sstr);
2309 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2310 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2311 SvCUR_set(dstr, len);
2312 *SvEND(dstr) = '\0';
2313 (void)SvPOK_only(dstr);
2316 if (sflags & SVp_NOK) {
2318 SvNVX(dstr) = SvNVX(sstr);
2320 if (sflags & SVp_IOK) {
2321 (void)SvIOK_on(dstr);
2322 SvIVX(dstr) = SvIVX(sstr);
2327 else if (sflags & SVp_NOK) {
2328 SvNVX(dstr) = SvNVX(sstr);
2329 (void)SvNOK_only(dstr);
2331 (void)SvIOK_on(dstr);
2332 SvIVX(dstr) = SvIVX(sstr);
2333 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2338 else if (sflags & SVp_IOK) {
2339 (void)SvIOK_only(dstr);
2340 SvIVX(dstr) = SvIVX(sstr);
2345 if (dtype == SVt_PVGV) {
2346 if (ckWARN(WARN_UNSAFE))
2347 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2350 (void)SvOK_off(dstr);
2356 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2358 sv_setsv(dstr,sstr);
2363 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2365 register char *dptr;
2366 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2367 elicit a warning, but it won't hurt. */
2368 SV_CHECK_THINKFIRST(sv);
2373 (void)SvUPGRADE(sv, SVt_PV);
2375 SvGROW(sv, len + 1);
2377 Move(ptr,dptr,len,char);
2380 (void)SvPOK_only(sv); /* validate pointer */
2385 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2387 sv_setpvn(sv,ptr,len);
2392 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2394 register STRLEN len;
2396 SV_CHECK_THINKFIRST(sv);
2402 (void)SvUPGRADE(sv, SVt_PV);
2404 SvGROW(sv, len + 1);
2405 Move(ptr,SvPVX(sv),len+1,char);
2407 (void)SvPOK_only(sv); /* validate pointer */
2412 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2419 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2421 SV_CHECK_THINKFIRST(sv);
2422 (void)SvUPGRADE(sv, SVt_PV);
2427 (void)SvOOK_off(sv);
2428 if (SvPVX(sv) && SvLEN(sv))
2429 Safefree(SvPVX(sv));
2430 Renew(ptr, len+1, char);
2433 SvLEN_set(sv, len+1);
2435 (void)SvPOK_only(sv); /* validate pointer */
2440 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2442 sv_usepvn(sv,ptr,len);
2447 Perl_sv_force_normal(pTHX_ register SV *sv)
2449 if (SvREADONLY(sv)) {
2451 if (PL_curcop != &PL_compiling)
2452 Perl_croak(aTHX_ PL_no_modify);
2456 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2461 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2465 register STRLEN delta;
2467 if (!ptr || !SvPOKp(sv))
2469 SV_CHECK_THINKFIRST(sv);
2470 if (SvTYPE(sv) < SVt_PVIV)
2471 sv_upgrade(sv,SVt_PVIV);
2474 if (!SvLEN(sv)) { /* make copy of shared string */
2475 char *pvx = SvPVX(sv);
2476 STRLEN len = SvCUR(sv);
2477 SvGROW(sv, len + 1);
2478 Move(pvx,SvPVX(sv),len,char);
2482 SvFLAGS(sv) |= SVf_OOK;
2484 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2485 delta = ptr - SvPVX(sv);
2493 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2498 junk = SvPV_force(sv, tlen);
2499 SvGROW(sv, tlen + len + 1);
2502 Move(ptr,SvPVX(sv)+tlen,len,char);
2505 (void)SvPOK_only(sv); /* validate pointer */
2510 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2512 sv_catpvn(sv,ptr,len);
2517 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2523 if (s = SvPV(sstr, len))
2524 sv_catpvn(dstr,s,len);
2528 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2530 sv_catsv(dstr,sstr);
2535 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2537 register STRLEN len;
2543 junk = SvPV_force(sv, tlen);
2545 SvGROW(sv, tlen + len + 1);
2548 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2550 (void)SvPOK_only(sv); /* validate pointer */
2555 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2562 Perl_newSV(pTHX_ STRLEN len)
2568 sv_upgrade(sv, SVt_PV);
2569 SvGROW(sv, len + 1);
2574 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2577 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2581 if (SvREADONLY(sv)) {
2583 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2584 Perl_croak(aTHX_ PL_no_modify);
2586 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2587 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2594 (void)SvUPGRADE(sv, SVt_PVMG);
2596 Newz(702,mg, 1, MAGIC);
2597 mg->mg_moremagic = SvMAGIC(sv);
2600 if (!obj || obj == sv || how == '#' || how == 'r')
2604 mg->mg_obj = SvREFCNT_inc(obj);
2605 mg->mg_flags |= MGf_REFCOUNTED;
2608 mg->mg_len = namlen;
2611 mg->mg_ptr = savepvn(name, namlen);
2612 else if (namlen == HEf_SVKEY)
2613 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2617 mg->mg_virtual = &PL_vtbl_sv;
2620 mg->mg_virtual = &PL_vtbl_amagic;
2623 mg->mg_virtual = &PL_vtbl_amagicelem;
2629 mg->mg_virtual = &PL_vtbl_bm;
2632 mg->mg_virtual = &PL_vtbl_regdata;
2635 mg->mg_virtual = &PL_vtbl_regdatum;
2638 mg->mg_virtual = &PL_vtbl_env;
2641 mg->mg_virtual = &PL_vtbl_fm;
2644 mg->mg_virtual = &PL_vtbl_envelem;
2647 mg->mg_virtual = &PL_vtbl_mglob;
2650 mg->mg_virtual = &PL_vtbl_isa;
2653 mg->mg_virtual = &PL_vtbl_isaelem;
2656 mg->mg_virtual = &PL_vtbl_nkeys;
2663 mg->mg_virtual = &PL_vtbl_dbline;
2667 mg->mg_virtual = &PL_vtbl_mutex;
2669 #endif /* USE_THREADS */
2670 #ifdef USE_LOCALE_COLLATE
2672 mg->mg_virtual = &PL_vtbl_collxfrm;
2674 #endif /* USE_LOCALE_COLLATE */
2676 mg->mg_virtual = &PL_vtbl_pack;
2680 mg->mg_virtual = &PL_vtbl_packelem;
2683 mg->mg_virtual = &PL_vtbl_regexp;
2686 mg->mg_virtual = &PL_vtbl_sig;
2689 mg->mg_virtual = &PL_vtbl_sigelem;
2692 mg->mg_virtual = &PL_vtbl_taint;
2696 mg->mg_virtual = &PL_vtbl_uvar;
2699 mg->mg_virtual = &PL_vtbl_vec;
2702 mg->mg_virtual = &PL_vtbl_substr;
2705 mg->mg_virtual = &PL_vtbl_defelem;
2708 mg->mg_virtual = &PL_vtbl_glob;
2711 mg->mg_virtual = &PL_vtbl_arylen;
2714 mg->mg_virtual = &PL_vtbl_pos;
2717 mg->mg_virtual = &PL_vtbl_backref;
2719 case '~': /* Reserved for use by extensions not perl internals. */
2720 /* Useful for attaching extension internal data to perl vars. */
2721 /* Note that multiple extensions may clash if magical scalars */
2722 /* etc holding private data from one are passed to another. */
2726 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
2730 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2734 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2738 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2741 for (mg = *mgp; mg; mg = *mgp) {
2742 if (mg->mg_type == type) {
2743 MGVTBL* vtbl = mg->mg_virtual;
2744 *mgp = mg->mg_moremagic;
2745 if (vtbl && (vtbl->svt_free != NULL))
2746 (VTBL->svt_free)(aTHX_ sv, mg);
2747 if (mg->mg_ptr && mg->mg_type != 'g')
2748 if (mg->mg_len >= 0)
2749 Safefree(mg->mg_ptr);
2750 else if (mg->mg_len == HEf_SVKEY)
2751 SvREFCNT_dec((SV*)mg->mg_ptr);
2752 if (mg->mg_flags & MGf_REFCOUNTED)
2753 SvREFCNT_dec(mg->mg_obj);
2757 mgp = &mg->mg_moremagic;
2761 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2768 Perl_sv_rvweaken(pTHX_ SV *sv)
2771 if (!SvOK(sv)) /* let undefs pass */
2774 Perl_croak(aTHX_ "Can't weaken a nonreference");
2775 else if (SvWEAKREF(sv)) {
2777 if (ckWARN(WARN_MISC))
2778 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
2782 sv_add_backref(tsv, sv);
2789 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
2793 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2794 av = (AV*)mg->mg_obj;
2797 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2798 SvREFCNT_dec(av); /* for sv_magic */
2804 S_sv_del_backref(pTHX_ SV *sv)
2811 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2812 Perl_croak(aTHX_ "panic: del_backref");
2813 av = (AV *)mg->mg_obj;
2818 svp[i] = &PL_sv_undef; /* XXX */
2825 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2829 register char *midend;
2830 register char *bigend;
2836 Perl_croak(aTHX_ "Can't modify non-existent substring");
2837 SvPV_force(bigstr, curlen);
2838 if (offset + len > curlen) {
2839 SvGROW(bigstr, offset+len+1);
2840 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2841 SvCUR_set(bigstr, offset+len);
2844 i = littlelen - len;
2845 if (i > 0) { /* string might grow */
2846 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2847 mid = big + offset + len;
2848 midend = bigend = big + SvCUR(bigstr);
2851 while (midend > mid) /* shove everything down */
2852 *--bigend = *--midend;
2853 Move(little,big+offset,littlelen,char);
2859 Move(little,SvPVX(bigstr)+offset,len,char);
2864 big = SvPVX(bigstr);
2867 bigend = big + SvCUR(bigstr);
2869 if (midend > bigend)
2870 Perl_croak(aTHX_ "panic: sv_insert");
2872 if (mid - big > bigend - midend) { /* faster to shorten from end */
2874 Move(little, mid, littlelen,char);
2877 i = bigend - midend;
2879 Move(midend, mid, i,char);
2883 SvCUR_set(bigstr, mid - big);
2886 else if (i = mid - big) { /* faster from front */
2887 midend -= littlelen;
2889 sv_chop(bigstr,midend-i);
2894 Move(little, mid, littlelen,char);
2896 else if (littlelen) {
2897 midend -= littlelen;
2898 sv_chop(bigstr,midend);
2899 Move(little,midend,littlelen,char);
2902 sv_chop(bigstr,midend);
2907 /* make sv point to what nstr did */
2910 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2913 U32 refcnt = SvREFCNT(sv);
2914 SV_CHECK_THINKFIRST(sv);
2915 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
2916 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
2917 if (SvMAGICAL(sv)) {
2921 sv_upgrade(nsv, SVt_PVMG);
2922 SvMAGIC(nsv) = SvMAGIC(sv);
2923 SvFLAGS(nsv) |= SvMAGICAL(sv);
2929 assert(!SvREFCNT(sv));
2930 StructCopy(nsv,sv,SV);
2931 SvREFCNT(sv) = refcnt;
2932 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2937 Perl_sv_clear(pTHX_ register SV *sv)
2941 assert(SvREFCNT(sv) == 0);
2945 if (PL_defstash) { /* Still have a symbol table? */
2950 Zero(&tmpref, 1, SV);
2951 sv_upgrade(&tmpref, SVt_RV);
2953 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
2954 SvREFCNT(&tmpref) = 1;
2957 stash = SvSTASH(sv);
2958 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2961 PUSHSTACKi(PERLSI_DESTROY);
2962 SvRV(&tmpref) = SvREFCNT_inc(sv);
2967 call_sv((SV*)GvCV(destructor),
2968 G_DISCARD|G_EVAL|G_KEEPERR);
2974 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
2976 del_XRV(SvANY(&tmpref));
2979 if (PL_in_clean_objs)
2980 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
2982 /* DESTROY gave object new lease on life */
2988 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
2989 SvOBJECT_off(sv); /* Curse the object. */
2990 if (SvTYPE(sv) != SVt_PVIO)
2991 --PL_sv_objcount; /* XXX Might want something more general */
2994 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2997 switch (SvTYPE(sv)) {
3000 IoIFP(sv) != PerlIO_stdin() &&
3001 IoIFP(sv) != PerlIO_stdout() &&
3002 IoIFP(sv) != PerlIO_stderr())
3004 io_close((IO*)sv, FALSE);
3007 PerlDir_close(IoDIRP(sv));
3010 Safefree(IoTOP_NAME(sv));
3011 Safefree(IoFMT_NAME(sv));
3012 Safefree(IoBOTTOM_NAME(sv));
3027 SvREFCNT_dec(LvTARG(sv));
3031 Safefree(GvNAME(sv));
3032 /* cannot decrease stash refcount yet, as we might recursively delete
3033 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3034 of stash until current sv is completely gone.
3035 -- JohnPC, 27 Mar 1998 */
3036 stash = GvSTASH(sv);
3042 (void)SvOOK_off(sv);
3050 SvREFCNT_dec(SvRV(sv));
3052 else if (SvPVX(sv) && SvLEN(sv))
3053 Safefree(SvPVX(sv));
3063 switch (SvTYPE(sv)) {
3079 del_XPVIV(SvANY(sv));
3082 del_XPVNV(SvANY(sv));
3085 del_XPVMG(SvANY(sv));
3088 del_XPVLV(SvANY(sv));
3091 del_XPVAV(SvANY(sv));
3094 del_XPVHV(SvANY(sv));
3097 del_XPVCV(SvANY(sv));
3100 del_XPVGV(SvANY(sv));
3101 /* code duplication for increased performance. */
3102 SvFLAGS(sv) &= SVf_BREAK;
3103 SvFLAGS(sv) |= SVTYPEMASK;
3104 /* decrease refcount of the stash that owns this GV, if any */
3106 SvREFCNT_dec(stash);
3107 return; /* not break, SvFLAGS reset already happened */
3109 del_XPVBM(SvANY(sv));
3112 del_XPVFM(SvANY(sv));
3115 del_XPVIO(SvANY(sv));
3118 SvFLAGS(sv) &= SVf_BREAK;
3119 SvFLAGS(sv) |= SVTYPEMASK;
3123 Perl_sv_newref(pTHX_ SV *sv)
3126 ATOMIC_INC(SvREFCNT(sv));
3131 Perl_sv_free(pTHX_ SV *sv)
3134 int refcount_is_zero;
3138 if (SvREFCNT(sv) == 0) {
3139 if (SvFLAGS(sv) & SVf_BREAK)
3141 if (PL_in_clean_all) /* All is fair */
3143 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3144 /* make sure SvREFCNT(sv)==0 happens very seldom */
3145 SvREFCNT(sv) = (~(U32)0)/2;
3148 if (ckWARN_d(WARN_INTERNAL))
3149 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3152 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3153 if (!refcount_is_zero)
3157 if (ckWARN_d(WARN_DEBUGGING))
3158 Perl_warner(aTHX_ WARN_DEBUGGING,
3159 "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3163 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3164 /* make sure SvREFCNT(sv)==0 happens very seldom */
3165 SvREFCNT(sv) = (~(U32)0)/2;
3174 Perl_sv_len(pTHX_ register SV *sv)
3183 len = mg_length(sv);
3185 junk = SvPV(sv, len);
3190 Perl_sv_len_utf8(pTHX_ register SV *sv)
3201 len = mg_length(sv);
3204 s = (U8*)SvPV(sv, len);
3215 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3220 I32 uoffset = *offsetp;
3226 start = s = (U8*)SvPV(sv, len);
3228 while (s < send && uoffset--)
3232 *offsetp = s - start;
3236 while (s < send && ulen--)
3246 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3255 s = (U8*)SvPV(sv, len);
3257 Perl_croak(aTHX_ "panic: bad byte offset");
3258 send = s + *offsetp;
3266 if (ckWARN_d(WARN_UTF8))
3267 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3275 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3287 pv1 = SvPV(str1, cur1);
3292 pv2 = SvPV(str2, cur2);
3297 return memEQ(pv1, pv2, cur1);
3301 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3304 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3306 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3310 return cur2 ? -1 : 0;
3315 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3318 return retval < 0 ? -1 : 1;
3323 return cur1 < cur2 ? -1 : 1;
3327 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3329 #ifdef USE_LOCALE_COLLATE
3335 if (PL_collation_standard)
3339 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3341 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3343 if (!pv1 || !len1) {
3354 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3357 return retval < 0 ? -1 : 1;
3360 * When the result of collation is equality, that doesn't mean
3361 * that there are no differences -- some locales exclude some
3362 * characters from consideration. So to avoid false equalities,
3363 * we use the raw string as a tiebreaker.
3369 #endif /* USE_LOCALE_COLLATE */
3371 return sv_cmp(sv1, sv2);
3374 #ifdef USE_LOCALE_COLLATE
3376 * Any scalar variable may carry an 'o' magic that contains the
3377 * scalar data of the variable transformed to such a format that
3378 * a normal memory comparison can be used to compare the data
3379 * according to the locale settings.
3382 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3386 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3387 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3392 Safefree(mg->mg_ptr);
3394 if ((xf = mem_collxfrm(s, len, &xlen))) {
3395 if (SvREADONLY(sv)) {
3398 return xf + sizeof(PL_collation_ix);
3401 sv_magic(sv, 0, 'o', 0, 0);
3402 mg = mg_find(sv, 'o');
3415 if (mg && mg->mg_ptr) {
3417 return mg->mg_ptr + sizeof(PL_collation_ix);
3425 #endif /* USE_LOCALE_COLLATE */
3428 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3433 register STDCHAR rslast;
3434 register STDCHAR *bp;
3438 SV_CHECK_THINKFIRST(sv);
3439 (void)SvUPGRADE(sv, SVt_PV);
3443 if (RsSNARF(PL_rs)) {
3447 else if (RsRECORD(PL_rs)) {
3448 I32 recsize, bytesread;
3451 /* Grab the size of the record we're getting */
3452 recsize = SvIV(SvRV(PL_rs));
3453 (void)SvPOK_only(sv); /* Validate pointer */
3454 buffer = SvGROW(sv, recsize + 1);
3457 /* VMS wants read instead of fread, because fread doesn't respect */
3458 /* RMS record boundaries. This is not necessarily a good thing to be */
3459 /* doing, but we've got no other real choice */
3460 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3462 bytesread = PerlIO_read(fp, buffer, recsize);
3464 SvCUR_set(sv, bytesread);
3465 buffer[bytesread] = '\0';
3466 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3468 else if (RsPARA(PL_rs)) {
3473 rsptr = SvPV(PL_rs, rslen);
3474 rslast = rslen ? rsptr[rslen - 1] : '\0';
3476 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3477 do { /* to make sure file boundaries work right */
3480 i = PerlIO_getc(fp);
3484 PerlIO_ungetc(fp,i);
3490 /* See if we know enough about I/O mechanism to cheat it ! */
3492 /* This used to be #ifdef test - it is made run-time test for ease
3493 of abstracting out stdio interface. One call should be cheap
3494 enough here - and may even be a macro allowing compile
3498 if (PerlIO_fast_gets(fp)) {
3501 * We're going to steal some values from the stdio struct
3502 * and put EVERYTHING in the innermost loop into registers.
3504 register STDCHAR *ptr;
3508 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3509 /* An ungetc()d char is handled separately from the regular
3510 * buffer, so we getc() it back out and stuff it in the buffer.
3512 i = PerlIO_getc(fp);
3513 if (i == EOF) return 0;
3514 *(--((*fp)->_ptr)) = (unsigned char) i;
3518 /* Here is some breathtakingly efficient cheating */
3520 cnt = PerlIO_get_cnt(fp); /* get count into register */
3521 (void)SvPOK_only(sv); /* validate pointer */
3522 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3523 if (cnt > 80 && SvLEN(sv) > append) {
3524 shortbuffered = cnt - SvLEN(sv) + append + 1;
3525 cnt -= shortbuffered;
3529 /* remember that cnt can be negative */
3530 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3535 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3536 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3537 DEBUG_P(PerlIO_printf(Perl_debug_log,
3538 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3539 DEBUG_P(PerlIO_printf(Perl_debug_log,
3540 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3541 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3542 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3547 while (cnt > 0) { /* this | eat */
3549 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3550 goto thats_all_folks; /* screams | sed :-) */
3554 Copy(ptr, bp, cnt, char); /* this | eat */
3555 bp += cnt; /* screams | dust */
3556 ptr += cnt; /* louder | sed :-) */
3561 if (shortbuffered) { /* oh well, must extend */
3562 cnt = shortbuffered;
3564 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3566 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3567 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3571 DEBUG_P(PerlIO_printf(Perl_debug_log,
3572 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3573 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3574 DEBUG_P(PerlIO_printf(Perl_debug_log,
3575 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3576 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3577 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3578 /* This used to call 'filbuf' in stdio form, but as that behaves like
3579 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3580 another abstraction. */
3581 i = PerlIO_getc(fp); /* get more characters */
3582 DEBUG_P(PerlIO_printf(Perl_debug_log,
3583 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3584 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3585 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3586 cnt = PerlIO_get_cnt(fp);
3587 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3588 DEBUG_P(PerlIO_printf(Perl_debug_log,
3589 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3591 if (i == EOF) /* all done for ever? */
3592 goto thats_really_all_folks;
3594 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3596 SvGROW(sv, bpx + cnt + 2);
3597 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3599 *bp++ = i; /* store character from PerlIO_getc */
3601 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3602 goto thats_all_folks;
3606 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3607 memNE((char*)bp - rslen, rsptr, rslen))
3608 goto screamer; /* go back to the fray */
3609 thats_really_all_folks:
3611 cnt += shortbuffered;
3612 DEBUG_P(PerlIO_printf(Perl_debug_log,
3613 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3614 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3615 DEBUG_P(PerlIO_printf(Perl_debug_log,
3616 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3617 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3618 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3620 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3621 DEBUG_P(PerlIO_printf(Perl_debug_log,
3622 "Screamer: done, len=%ld, string=|%.*s|\n",
3623 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3628 /*The big, slow, and stupid way */
3631 /* Need to work around EPOC SDK features */
3632 /* On WINS: MS VC5 generates calls to _chkstk, */
3633 /* if a `large' stack frame is allocated */
3634 /* gcc on MARM does not generate calls like these */
3640 register STDCHAR *bpe = buf + sizeof(buf);
3642 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3643 ; /* keep reading */
3647 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3648 /* Accomodate broken VAXC compiler, which applies U8 cast to
3649 * both args of ?: operator, causing EOF to change into 255
3651 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3655 sv_catpvn(sv, (char *) buf, cnt);
3657 sv_setpvn(sv, (char *) buf, cnt);
3659 if (i != EOF && /* joy */
3661 SvCUR(sv) < rslen ||
3662 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3666 * If we're reading from a TTY and we get a short read,
3667 * indicating that the user hit his EOF character, we need
3668 * to notice it now, because if we try to read from the TTY
3669 * again, the EOF condition will disappear.
3671 * The comparison of cnt to sizeof(buf) is an optimization
3672 * that prevents unnecessary calls to feof().
3676 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3681 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3682 while (i != EOF) { /* to make sure file boundaries work right */
3683 i = PerlIO_getc(fp);
3685 PerlIO_ungetc(fp,i);
3692 win32_strip_return(sv);
3695 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3700 Perl_sv_inc(pTHX_ register SV *sv)
3709 if (SvTHINKFIRST(sv)) {
3710 if (SvREADONLY(sv)) {
3712 if (PL_curcop != &PL_compiling)
3713 Perl_croak(aTHX_ PL_no_modify);
3717 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3724 flags = SvFLAGS(sv);
3725 if (flags & SVp_NOK) {
3726 (void)SvNOK_only(sv);
3730 if (flags & SVp_IOK) {
3732 if (SvUVX(sv) == UV_MAX)
3733 sv_setnv(sv, (NV)UV_MAX + 1.0);
3735 (void)SvIOK_only_UV(sv);
3738 if (SvIVX(sv) == IV_MAX)
3739 sv_setnv(sv, (NV)IV_MAX + 1.0);
3741 (void)SvIOK_only(sv);
3747 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3748 if ((flags & SVTYPEMASK) < SVt_PVNV)
3749 sv_upgrade(sv, SVt_NV);
3751 (void)SvNOK_only(sv);
3755 while (isALPHA(*d)) d++;
3756 while (isDIGIT(*d)) d++;
3758 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
3762 while (d >= SvPVX(sv)) {
3770 /* MKS: The original code here died if letters weren't consecutive.
3771 * at least it didn't have to worry about non-C locales. The
3772 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3773 * arranged in order (although not consecutively) and that only
3774 * [A-Za-z] are accepted by isALPHA in the C locale.
3776 if (*d != 'z' && *d != 'Z') {
3777 do { ++*d; } while (!isALPHA(*d));
3780 *(d--) -= 'z' - 'a';
3785 *(d--) -= 'z' - 'a' + 1;
3789 /* oh,oh, the number grew */
3790 SvGROW(sv, SvCUR(sv) + 2);
3792 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3801 Perl_sv_dec(pTHX_ register SV *sv)
3809 if (SvTHINKFIRST(sv)) {
3810 if (SvREADONLY(sv)) {
3812 if (PL_curcop != &PL_compiling)
3813 Perl_croak(aTHX_ PL_no_modify);
3817 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3824 flags = SvFLAGS(sv);
3825 if (flags & SVp_NOK) {
3827 (void)SvNOK_only(sv);
3830 if (flags & SVp_IOK) {
3832 if (SvUVX(sv) == 0) {
3833 (void)SvIOK_only(sv);
3837 (void)SvIOK_only_UV(sv);
3841 if (SvIVX(sv) == IV_MIN)
3842 sv_setnv(sv, (NV)IV_MIN - 1.0);
3844 (void)SvIOK_only(sv);
3850 if (!(flags & SVp_POK)) {
3851 if ((flags & SVTYPEMASK) < SVt_PVNV)
3852 sv_upgrade(sv, SVt_NV);
3854 (void)SvNOK_only(sv);
3857 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
3860 /* Make a string that will exist for the duration of the expression
3861 * evaluation. Actually, it may have to last longer than that, but
3862 * hopefully we won't free it until it has been assigned to a
3863 * permanent location. */
3866 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3872 sv_setsv(sv,oldstr);
3874 PL_tmps_stack[++PL_tmps_ix] = sv;
3880 Perl_sv_newmortal(pTHX)
3886 SvFLAGS(sv) = SVs_TEMP;
3888 PL_tmps_stack[++PL_tmps_ix] = sv;
3892 /* same thing without the copying */
3895 Perl_sv_2mortal(pTHX_ register SV *sv)
3900 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3903 PL_tmps_stack[++PL_tmps_ix] = sv;
3909 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3916 sv_setpvn(sv,s,len);
3921 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3926 sv_setpvn(sv,s,len);
3930 #if defined(PERL_IMPLICIT_CONTEXT)
3932 Perl_newSVpvf_nocontext(const char* pat, ...)
3937 va_start(args, pat);
3938 sv = vnewSVpvf(pat, &args);
3945 Perl_newSVpvf(pTHX_ const char* pat, ...)
3949 va_start(args, pat);
3950 sv = vnewSVpvf(pat, &args);
3956 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
3960 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
3965 Perl_newSVnv(pTHX_ NV n)
3975 Perl_newSViv(pTHX_ IV i)
3985 Perl_newRV_noinc(pTHX_ SV *tmpRef)
3991 sv_upgrade(sv, SVt_RV);
3999 Perl_newRV(pTHX_ SV *tmpRef)
4001 return newRV_noinc(SvREFCNT_inc(tmpRef));
4004 /* make an exact duplicate of old */
4007 Perl_newSVsv(pTHX_ register SV *old)
4014 if (SvTYPE(old) == SVTYPEMASK) {
4015 if (ckWARN_d(WARN_INTERNAL))
4016 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4031 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4039 char todo[PERL_UCHAR_MAX+1];
4044 if (!*s) { /* reset ?? searches */
4045 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4046 pm->op_pmdynflags &= ~PMdf_USED;
4051 /* reset variables */
4053 if (!HvARRAY(stash))
4056 Zero(todo, 256, char);
4058 i = (unsigned char)*s;
4062 max = (unsigned char)*s++;
4063 for ( ; i <= max; i++) {
4066 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4067 for (entry = HvARRAY(stash)[i];
4069 entry = HeNEXT(entry))
4071 if (!todo[(U8)*HeKEY(entry)])
4073 gv = (GV*)HeVAL(entry);
4075 if (SvTHINKFIRST(sv)) {
4076 if (!SvREADONLY(sv) && SvROK(sv))
4081 if (SvTYPE(sv) >= SVt_PV) {
4083 if (SvPVX(sv) != Nullch)
4090 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4092 #ifndef VMS /* VMS has no environ array */
4094 environ[0] = Nullch;
4103 Perl_sv_2io(pTHX_ SV *sv)
4109 switch (SvTYPE(sv)) {
4117 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4121 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4123 return sv_2io(SvRV(sv));
4124 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4130 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4137 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4144 return *gvp = Nullgv, Nullcv;
4145 switch (SvTYPE(sv)) {
4165 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4166 tryAMAGICunDEREF(to_cv);
4169 if (SvTYPE(sv) == SVt_PVCV) {
4178 Perl_croak(aTHX_ "Not a subroutine reference");
4183 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4189 if (lref && !GvCVu(gv)) {
4192 tmpsv = NEWSV(704,0);
4193 gv_efullname3(tmpsv, gv, Nullch);
4194 /* XXX this is probably not what they think they're getting.
4195 * It has the same effect as "sub name;", i.e. just a forward
4197 newSUB(start_subparse(FALSE, 0),
4198 newSVOP(OP_CONST, 0, tmpsv),
4203 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4210 Perl_sv_true(pTHX_ register SV *sv)
4217 if ((tXpv = (XPV*)SvANY(sv)) &&
4218 (*tXpv->xpv_pv > '0' ||
4219 tXpv->xpv_cur > 1 ||
4220 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4227 return SvIVX(sv) != 0;
4230 return SvNVX(sv) != 0.0;
4232 return sv_2bool(sv);
4238 Perl_sv_iv(pTHX_ register SV *sv)
4242 return (IV)SvUVX(sv);
4249 Perl_sv_uv(pTHX_ register SV *sv)
4254 return (UV)SvIVX(sv);
4260 Perl_sv_nv(pTHX_ register SV *sv)
4268 Perl_sv_pv(pTHX_ SV *sv)
4275 return sv_2pv(sv, &n_a);
4279 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4285 return sv_2pv(sv, lp);
4289 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4293 if (SvTHINKFIRST(sv) && !SvROK(sv))
4294 sv_force_normal(sv);
4300 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4302 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4303 PL_op_name[PL_op->op_type]);
4307 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4312 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4313 SvGROW(sv, len + 1);
4314 Move(s,SvPVX(sv),len,char);
4319 SvPOK_on(sv); /* validate pointer */
4321 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4322 (unsigned long)sv,SvPVX(sv)));
4329 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4331 if (ob && SvOBJECT(sv))
4332 return HvNAME(SvSTASH(sv));
4334 switch (SvTYPE(sv)) {
4348 case SVt_PVLV: return "LVALUE";
4349 case SVt_PVAV: return "ARRAY";
4350 case SVt_PVHV: return "HASH";
4351 case SVt_PVCV: return "CODE";
4352 case SVt_PVGV: return "GLOB";
4353 case SVt_PVFM: return "FORMAT";
4354 default: return "UNKNOWN";
4360 Perl_sv_isobject(pTHX_ SV *sv)
4375 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4387 return strEQ(HvNAME(SvSTASH(sv)), name);
4391 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4398 SV_CHECK_THINKFIRST(rv);
4401 if (SvTYPE(rv) < SVt_RV)
4402 sv_upgrade(rv, SVt_RV);
4409 HV* stash = gv_stashpv(classname, TRUE);
4410 (void)sv_bless(rv, stash);
4416 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4419 sv_setsv(rv, &PL_sv_undef);
4423 sv_setiv(newSVrv(rv,classname), (IV)pv);
4428 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4430 sv_setiv(newSVrv(rv,classname), iv);
4435 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4437 sv_setnv(newSVrv(rv,classname), nv);
4442 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4444 sv_setpvn(newSVrv(rv,classname), pv, n);
4449 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4454 Perl_croak(aTHX_ "Can't bless non-reference value");
4456 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4457 if (SvREADONLY(tmpRef))
4458 Perl_croak(aTHX_ PL_no_modify);
4459 if (SvOBJECT(tmpRef)) {
4460 if (SvTYPE(tmpRef) != SVt_PVIO)
4462 SvREFCNT_dec(SvSTASH(tmpRef));
4465 SvOBJECT_on(tmpRef);
4466 if (SvTYPE(tmpRef) != SVt_PVIO)
4468 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4469 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4480 S_sv_unglob(pTHX_ SV *sv)
4482 assert(SvTYPE(sv) == SVt_PVGV);
4487 SvREFCNT_dec(GvSTASH(sv));
4488 GvSTASH(sv) = Nullhv;
4490 sv_unmagic(sv, '*');
4491 Safefree(GvNAME(sv));
4493 SvFLAGS(sv) &= ~SVTYPEMASK;
4494 SvFLAGS(sv) |= SVt_PVMG;
4498 Perl_sv_unref(pTHX_ SV *sv)
4502 if (SvWEAKREF(sv)) {
4510 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4513 sv_2mortal(rv); /* Schedule for freeing later */
4517 Perl_sv_taint(pTHX_ SV *sv)
4519 sv_magic((sv), Nullsv, 't', Nullch, 0);
4523 Perl_sv_untaint(pTHX_ SV *sv)
4525 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4526 MAGIC *mg = mg_find(sv, 't');
4533 Perl_sv_tainted(pTHX_ SV *sv)
4535 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4536 MAGIC *mg = mg_find(sv, 't');
4537 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4544 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4546 char buf[TYPE_CHARS(UV)];
4548 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4550 sv_setpvn(sv, ptr, ebuf - ptr);
4555 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4557 char buf[TYPE_CHARS(UV)];
4559 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4561 sv_setpvn(sv, ptr, ebuf - ptr);
4565 #if defined(PERL_IMPLICIT_CONTEXT)
4567 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4571 va_start(args, pat);
4572 sv_vsetpvf(sv, pat, &args);
4578 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4582 va_start(args, pat);
4583 sv_vsetpvf_mg(sv, pat, &args);
4589 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4592 va_start(args, pat);
4593 sv_vsetpvf(sv, pat, &args);
4598 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4600 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4604 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4607 va_start(args, pat);
4608 sv_vsetpvf_mg(sv, pat, &args);
4613 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4615 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_vcatpvf(sv, pat, &args);
4631 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4635 va_start(args, pat);
4636 sv_vcatpvf_mg(sv, pat, &args);
4642 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4645 va_start(args, pat);
4646 sv_vcatpvf(sv, pat, &args);
4651 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4653 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4657 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4660 va_start(args, pat);
4661 sv_vcatpvf_mg(sv, pat, &args);
4666 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4668 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4673 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4675 sv_setpvn(sv, "", 0);
4676 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4680 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4688 static char nullstr[] = "(null)";
4690 /* no matter what, this is a string now */
4691 (void)SvPV_force(sv, origlen);
4693 /* special-case "", "%s", and "%_" */
4696 if (patlen == 2 && pat[0] == '%') {
4700 char *s = va_arg(*args, char*);
4701 sv_catpv(sv, s ? s : nullstr);
4703 else if (svix < svmax)
4704 sv_catsv(sv, *svargs);
4708 sv_catsv(sv, va_arg(*args, SV*));
4711 /* See comment on '_' below */
4716 patend = (char*)pat + patlen;
4717 for (p = (char*)pat; p < patend; p = q) {
4725 bool has_precis = FALSE;
4730 STRLEN esignlen = 0;
4732 char *eptr = Nullch;
4734 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4745 for (q = p; q < patend && *q != '%'; ++q) ;
4747 sv_catpvn(sv, p, q - p);
4785 case '1': case '2': case '3':
4786 case '4': case '5': case '6':
4787 case '7': case '8': case '9':
4790 width = width * 10 + (*q++ - '0');
4795 i = va_arg(*args, int);
4797 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4799 width = (i < 0) ? -i : i;
4810 i = va_arg(*args, int);
4812 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4813 precis = (i < 0) ? 0 : i;
4819 precis = precis * 10 + (*q++ - '0');
4829 if (*(q + 1) == 'l') { /* lld */
4861 uv = va_arg(*args, int);
4863 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4865 eptr = (char*)utf8buf;
4866 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4870 c = va_arg(*args, int);
4872 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4879 eptr = va_arg(*args, char*);
4881 elen = strlen(eptr);
4884 elen = sizeof nullstr - 1;
4887 else if (svix < svmax) {
4888 eptr = SvPVx(svargs[svix++], elen);
4890 if (has_precis && precis < elen) {
4892 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4895 if (width) { /* fudge width (can't fudge elen) */
4896 width += elen - sv_len_utf8(svargs[svix - 1]);
4904 * The "%_" hack might have to be changed someday,
4905 * if ISO or ANSI decide to use '_' for something.
4906 * So we keep it hidden from users' code.
4910 eptr = SvPVx(va_arg(*args, SV*), elen);
4913 if (has_precis && elen > precis)
4921 uv = (UV)va_arg(*args, void*);
4923 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4938 case 'h': iv = (short)va_arg(*args, int); break;
4940 default: iv = va_arg(*args, IV); break;
4942 default: iv = va_arg(*args, int); break;
4944 case 'l': iv = va_arg(*args, long); break;
4945 case 'V': iv = va_arg(*args, IV); break;
4947 case 'q': iv = va_arg(*args, Quad_t); break;
4952 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4954 case 'h': iv = (short)iv; break;
4958 default: iv = (int)iv; break;
4960 case 'l': iv = (long)iv; break;
4963 case 'q': iv = (Quad_t)iv; break;
4970 esignbuf[esignlen++] = plus;
4974 esignbuf[esignlen++] = '-';
5012 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5014 default: uv = va_arg(*args, UV); break;
5016 default: uv = va_arg(*args, unsigned); break;
5018 case 'l': uv = va_arg(*args, unsigned long); break;
5019 case 'V': uv = va_arg(*args, UV); break;
5021 case 'q': uv = va_arg(*args, Quad_t); break;
5026 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5028 case 'h': uv = (unsigned short)uv; break;
5032 default: uv = (unsigned)uv; break;
5034 case 'l': uv = (unsigned long)uv; break;
5037 case 'q': uv = (Quad_t)uv; break;
5043 eptr = ebuf + sizeof ebuf;
5049 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5055 esignbuf[esignlen++] = '0';
5056 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5062 *--eptr = '0' + dig;
5064 if (alt && *eptr != '0')
5070 *--eptr = '0' + dig;
5072 if (alt && *eptr != '0')
5075 default: /* it had better be ten or less */
5078 *--eptr = '0' + dig;
5079 } while (uv /= base);
5082 elen = (ebuf + sizeof ebuf) - eptr;
5085 zeros = precis - elen;
5086 else if (precis == 0 && elen == 1 && *eptr == '0')
5091 /* FLOATING POINT */
5094 c = 'f'; /* maybe %F isn't supported here */
5100 /* This is evil, but floating point is even more evil */
5103 nv = va_arg(*args, NV);
5105 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5108 if (c != 'e' && c != 'E') {
5110 (void)frexp(nv, &i);
5111 if (i == PERL_INT_MIN)
5112 Perl_die(aTHX_ "panic: frexp");
5114 need = BIT_DIGITS(i);
5116 need += has_precis ? precis : 6; /* known default */
5120 need += 20; /* fudge factor */
5121 if (PL_efloatsize < need) {
5122 Safefree(PL_efloatbuf);
5123 PL_efloatsize = need + 20; /* more fudge */
5124 New(906, PL_efloatbuf, PL_efloatsize, char);
5127 eptr = ebuf + sizeof ebuf;
5130 #ifdef USE_LONG_DOUBLE
5132 char* p = PRIfldbl + sizeof(PRIfldbl) - 3;
5133 while (p >= PRIfldbl) { *--eptr = *p-- }
5138 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5143 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5156 RESTORE_NUMERIC_STANDARD();
5157 (void)sprintf(PL_efloatbuf, eptr, nv);
5158 RESTORE_NUMERIC_LOCAL();
5161 eptr = PL_efloatbuf;
5162 elen = strlen(PL_efloatbuf);
5166 * User-defined locales may include arbitrary characters.
5167 * And, unfortunately, some system may alloc the "C" locale
5168 * to be overridden by a malicious user.
5171 *used_locale = TRUE;
5172 #endif /* LC_NUMERIC */
5179 i = SvCUR(sv) - origlen;
5182 case 'h': *(va_arg(*args, short*)) = i; break;
5184 default: *(va_arg(*args, IV*)) = i; break;
5186 default: *(va_arg(*args, int*)) = i; break;
5188 case 'l': *(va_arg(*args, long*)) = i; break;
5189 case 'V': *(va_arg(*args, IV*)) = i; break;
5191 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5195 else if (svix < svmax)
5196 sv_setuv(svargs[svix++], (UV)i);
5197 continue; /* not "break" */
5203 if (!args && ckWARN(WARN_PRINTF) &&
5204 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5205 SV *msg = sv_newmortal();
5206 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5207 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5211 Perl_sv_catpvf(aTHX_ msg,
5212 "\"%%%c\"", c & 0xFF);
5214 Perl_sv_catpvf(aTHX_ msg,
5215 "\"%%\\%03" PERL_PRIo64 "\"",
5218 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ?
5219 "\"%%%c\"" : "\"%%\\%03o\"",
5223 sv_catpv(msg, "end of string");
5224 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5227 /* output mangled stuff ... */
5233 /* ... right here, because formatting flags should not apply */
5234 SvGROW(sv, SvCUR(sv) + elen + 1);
5236 memcpy(p, eptr, elen);
5239 SvCUR(sv) = p - SvPVX(sv);
5240 continue; /* not "break" */
5243 have = esignlen + zeros + elen;
5244 need = (have > width ? have : width);
5247 SvGROW(sv, SvCUR(sv) + need + 1);
5249 if (esignlen && fill == '0') {
5250 for (i = 0; i < esignlen; i++)
5254 memset(p, fill, gap);
5257 if (esignlen && fill != '0') {
5258 for (i = 0; i < esignlen; i++)
5262 for (i = zeros; i; i--)
5266 memcpy(p, eptr, elen);
5270 memset(p, ' ', gap);
5274 SvCUR(sv) = p - SvPVX(sv);
5285 do_report_used(pTHXo_ SV *sv)
5287 if (SvTYPE(sv) != SVTYPEMASK) {
5288 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
5289 PerlIO_printf(PerlIO_stderr(), "****\n");
5295 do_clean_objs(pTHXo_ SV *sv)
5299 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5300 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
5306 /* XXX Might want to check arrays, etc. */
5309 #ifndef DISABLE_DESTRUCTOR_KLUDGE
5311 do_clean_named_objs(pTHXo_ SV *sv)
5313 if (SvTYPE(sv) == SVt_PVGV) {
5314 if ( SvOBJECT(GvSV(sv)) ||
5315 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
5316 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
5317 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
5318 GvCV(sv) && SvOBJECT(GvCV(sv)) )
5320 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
5328 do_clean_all(pTHXo_ SV *sv)
5330 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
5331 SvFLAGS(sv) |= SVf_BREAK;