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 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
34 (p) = (SV*)safemalloc(sizeof(SV)); \
46 Safefree((char*)(p)); \
51 static I32 registry_size;
53 #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
55 #define REG_REPLACE(sv,a,b) \
57 void* p = sv->sv_any; \
58 I32 h = REGHASH(sv, registry_size); \
60 while (registry[i] != (a)) { \
61 if (++i >= registry_size) \
64 Perl_die(aTHX_ "SV registry bug"); \
69 #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
70 #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
73 S_reg_add(pTHX_ SV *sv)
75 if (PL_sv_count >= (registry_size >> 1))
77 SV **oldreg = registry;
78 I32 oldsize = registry_size;
80 registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
81 Newz(707, registry, registry_size, SV*);
86 for (i = 0; i < oldsize; ++i) {
87 SV* oldsv = oldreg[i];
100 S_reg_remove(pTHX_ SV *sv)
107 S_visit(pTHX_ SVFUNC_t f)
111 for (i = 0; i < registry_size; ++i) {
112 SV* sv = registry[i];
113 if (sv && SvTYPE(sv) != SVTYPEMASK)
119 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
121 if (!(flags & SVf_FAKE))
128 * "A time to plant, and a time to uproot what was planted..."
131 #define plant_SV(p) \
133 SvANY(p) = (void *)PL_sv_root; \
134 SvFLAGS(p) = SVTYPEMASK; \
139 /* sv_mutex must be held while calling uproot_SV() */
140 #define uproot_SV(p) \
143 PL_sv_root = (SV*)SvANY(p); \
165 if (PL_debug & 32768) \
173 S_del_sv(pTHX_ SV *p)
175 if (PL_debug & 32768) {
180 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
182 svend = &sva[SvREFCNT(sva)];
183 if (p >= sv && p < svend)
187 if (ckWARN_d(WARN_INTERNAL))
188 Perl_warner(aTHX_ WARN_INTERNAL,
189 "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
196 #else /* ! DEBUGGING */
198 #define del_SV(p) plant_SV(p)
200 #endif /* DEBUGGING */
203 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
208 Zero(sva, size, char);
210 /* The first SV in an arena isn't an SV. */
211 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
212 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
213 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
215 PL_sv_arenaroot = sva;
216 PL_sv_root = sva + 1;
218 svend = &sva[SvREFCNT(sva) - 1];
221 SvANY(sv) = (void *)(SV*)(sv + 1);
222 SvFLAGS(sv) = SVTYPEMASK;
226 SvFLAGS(sv) = SVTYPEMASK;
229 /* sv_mutex must be held while calling more_sv() */
236 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
237 PL_nice_chunk = Nullch;
240 char *chunk; /* must use New here to match call to */
241 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
242 sv_add_arena(chunk, 1008, 0);
249 S_visit(pTHX_ SVFUNC_t f)
255 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
256 svend = &sva[SvREFCNT(sva)];
257 for (sv = sva + 1; sv < svend; ++sv) {
258 if (SvTYPE(sv) != SVTYPEMASK)
267 Perl_sv_report_used(pTHX)
269 visit(do_report_used);
273 Perl_sv_clean_objs(pTHX)
275 PL_in_clean_objs = TRUE;
276 visit(do_clean_objs);
277 #ifndef DISABLE_DESTRUCTOR_KLUDGE
278 /* some barnacles may yet remain, clinging to typeglobs */
279 visit(do_clean_named_objs);
281 PL_in_clean_objs = FALSE;
285 Perl_sv_clean_all(pTHX)
287 PL_in_clean_all = TRUE;
289 PL_in_clean_all = FALSE;
293 Perl_sv_free_arenas(pTHX)
298 /* Free arenas here, but be careful about fake ones. (We assume
299 contiguity of the fake ones with the corresponding real ones.) */
301 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
302 svanext = (SV*) SvANY(sva);
303 while (svanext && SvFAKE(svanext))
304 svanext = (SV*) SvANY(svanext);
307 Safefree((void *)sva);
311 Safefree(PL_nice_chunk);
312 PL_nice_chunk = Nullch;
313 PL_nice_chunk_size = 0;
327 * See comment in more_xiv() -- RAM.
329 PL_xiv_root = *(IV**)xiv;
331 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
335 S_del_xiv(pTHX_ XPVIV *p)
337 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
339 *(IV**)xiv = PL_xiv_root;
350 New(705, ptr, 1008/sizeof(XPV), XPV);
351 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
352 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
355 xivend = &xiv[1008 / sizeof(IV) - 1];
356 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
358 while (xiv < xivend) {
359 *(IV**)xiv = (IV *)(xiv + 1);
373 PL_xnv_root = *(NV**)xnv;
375 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
379 S_del_xnv(pTHX_ XPVNV *p)
381 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
383 *(NV**)xnv = PL_xnv_root;
393 New(711, xnv, 1008/sizeof(NV), NV);
394 xnvend = &xnv[1008 / sizeof(NV) - 1];
395 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
397 while (xnv < xnvend) {
398 *(NV**)xnv = (NV*)(xnv + 1);
412 PL_xrv_root = (XRV*)xrv->xrv_rv;
418 S_del_xrv(pTHX_ XRV *p)
421 p->xrv_rv = (SV*)PL_xrv_root;
430 register XRV* xrvend;
431 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
433 xrvend = &xrv[1008 / sizeof(XRV) - 1];
434 while (xrv < xrvend) {
435 xrv->xrv_rv = (SV*)(xrv + 1);
449 PL_xpv_root = (XPV*)xpv->xpv_pv;
455 S_del_xpv(pTHX_ XPV *p)
458 p->xpv_pv = (char*)PL_xpv_root;
467 register XPV* xpvend;
468 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
470 xpvend = &xpv[1008 / sizeof(XPV) - 1];
471 while (xpv < xpvend) {
472 xpv->xpv_pv = (char*)(xpv + 1);
479 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
480 #define del_XIV(p) Safefree((char*)p)
482 #define new_XIV() (void*)new_xiv()
483 #define del_XIV(p) del_xiv((XPVIV*) p)
487 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
488 #define del_XNV(p) Safefree((char*)p)
490 #define new_XNV() (void*)new_xnv()
491 #define del_XNV(p) del_xnv((XPVNV*) p)
495 #define new_XRV() (void*)safemalloc(sizeof(XRV))
496 #define del_XRV(p) Safefree((char*)p)
498 #define new_XRV() (void*)new_xrv()
499 #define del_XRV(p) del_xrv((XRV*) p)
503 #define new_XPV() (void*)safemalloc(sizeof(XPV))
504 #define del_XPV(p) Safefree((char*)p)
506 #define new_XPV() (void*)new_xpv()
507 #define del_XPV(p) del_xpv((XPV *)p)
511 # define my_safemalloc(s) safemalloc(s)
512 # define my_safefree(s) safefree(s)
515 S_my_safemalloc(MEM_SIZE size)
518 New(717, p, size, char);
521 # define my_safefree(s) Safefree(s)
524 #define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
525 #define del_XPVIV(p) my_safefree((char*)p)
527 #define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
528 #define del_XPVNV(p) my_safefree((char*)p)
530 #define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
531 #define del_XPVMG(p) my_safefree((char*)p)
533 #define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
534 #define del_XPVLV(p) my_safefree((char*)p)
536 #define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
537 #define del_XPVAV(p) my_safefree((char*)p)
539 #define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
540 #define del_XPVHV(p) my_safefree((char*)p)
542 #define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
543 #define del_XPVCV(p) my_safefree((char*)p)
545 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
546 #define del_XPVGV(p) my_safefree((char*)p)
548 #define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
549 #define del_XPVBM(p) my_safefree((char*)p)
551 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
552 #define del_XPVFM(p) my_safefree((char*)p)
554 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
555 #define del_XPVIO(p) my_safefree((char*)p)
558 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
568 if (SvTYPE(sv) == mt)
574 switch (SvTYPE(sv)) {
595 else if (mt < SVt_PVIV)
612 pv = (char*)SvRV(sv);
616 nv = (NV)(unsigned long)pv;
632 else if (mt == SVt_NV)
643 del_XPVIV(SvANY(sv));
653 del_XPVNV(SvANY(sv));
663 del_XPVMG(SvANY(sv));
666 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
671 Perl_croak(aTHX_ "Can't upgrade to undef");
673 SvANY(sv) = new_XIV();
677 SvANY(sv) = new_XNV();
681 SvANY(sv) = new_XRV();
685 SvANY(sv) = new_XPV();
691 SvANY(sv) = new_XPVIV();
701 SvANY(sv) = new_XPVNV();
709 SvANY(sv) = new_XPVMG();
719 SvANY(sv) = new_XPVLV();
733 SvANY(sv) = new_XPVAV();
748 SvANY(sv) = new_XPVHV();
764 SvANY(sv) = new_XPVCV();
765 Zero(SvANY(sv), 1, XPVCV);
775 SvANY(sv) = new_XPVGV();
790 SvANY(sv) = new_XPVBM();
803 SvANY(sv) = new_XPVFM();
804 Zero(SvANY(sv), 1, XPVFM);
814 SvANY(sv) = new_XPVIO();
815 Zero(SvANY(sv), 1, XPVIO);
826 SvFLAGS(sv) &= ~SVTYPEMASK;
832 Perl_sv_backoff(pTHX_ register SV *sv)
837 SvLEN(sv) += SvIVX(sv);
838 SvPVX(sv) -= SvIVX(sv);
840 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
842 SvFLAGS(sv) &= ~SVf_OOK;
847 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
852 if (newlen >= 0x10000) {
853 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
856 #endif /* HAS_64K_LIMIT */
859 if (SvTYPE(sv) < SVt_PV) {
860 sv_upgrade(sv, SVt_PV);
863 else if (SvOOK(sv)) { /* pv is offset? */
866 if (newlen > SvLEN(sv))
867 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
869 if (newlen >= 0x10000)
875 if (newlen > SvLEN(sv)) { /* need more room? */
876 if (SvLEN(sv) && s) {
877 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
878 STRLEN l = malloced_size((void*)SvPVX(sv));
884 Renew(s,newlen,char);
887 New(703,s,newlen,char);
889 SvLEN_set(sv, newlen);
895 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
897 SV_CHECK_THINKFIRST(sv);
898 switch (SvTYPE(sv)) {
900 sv_upgrade(sv, SVt_IV);
903 sv_upgrade(sv, SVt_PVNV);
907 sv_upgrade(sv, SVt_PVIV);
918 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
919 PL_op_desc[PL_op->op_type]);
922 (void)SvIOK_only(sv); /* validate number */
928 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
935 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
943 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
950 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
952 SV_CHECK_THINKFIRST(sv);
953 switch (SvTYPE(sv)) {
956 sv_upgrade(sv, SVt_NV);
961 sv_upgrade(sv, SVt_PVNV);
972 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
973 PL_op_name[PL_op->op_type]);
977 (void)SvNOK_only(sv); /* validate number */
982 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
989 S_not_a_number(pTHX_ SV *sv)
995 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
996 /* each *s can expand to 4 chars + "...\0",
997 i.e. need room for 8 chars */
999 for (s = SvPVX(sv); *s && d < limit; s++) {
1001 if (ch & 128 && !isPRINT_LC(ch)) {
1010 else if (ch == '\r') {
1014 else if (ch == '\f') {
1018 else if (ch == '\\') {
1022 else if (isPRINT_LC(ch))
1037 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
1038 PL_op_name[PL_op->op_type]);
1040 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
1043 /* the number can be converted to integer with atol() or atoll() */
1044 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1045 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1046 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1047 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1049 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1050 until proven guilty, assume that things are not that bad... */
1053 Perl_sv_2iv(pTHX_ register SV *sv)
1057 if (SvGMAGICAL(sv)) {
1062 return I_V(SvNVX(sv));
1064 if (SvPOKp(sv) && SvLEN(sv))
1067 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1069 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1070 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1075 if (SvTHINKFIRST(sv)) {
1078 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1079 return SvIV(tmpstr);
1080 return (IV)SvRV(sv);
1082 if (SvREADONLY(sv) && !SvOK(sv)) {
1084 if (ckWARN(WARN_UNINITIALIZED))
1085 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1091 return (IV)(SvUVX(sv));
1098 /* We can cache the IV/UV value even if it not good enough
1099 * to reconstruct NV, since the conversion to PV will prefer
1103 if (SvTYPE(sv) == SVt_NV)
1104 sv_upgrade(sv, SVt_PVNV);
1107 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1108 SvIVX(sv) = I_V(SvNVX(sv));
1110 SvUVX(sv) = U_V(SvNVX(sv));
1114 DEBUG_c(PerlIO_printf(Perl_debug_log,
1115 "0x%" PERL_PRIx64 " 2iv(%" PERL_PRIu64 " => %" PERL_PRId64 ") (as unsigned)\n",
1117 (UV)SvUVX(sv), (IV)SvUVX(sv)));
1119 DEBUG_c(PerlIO_printf(Perl_debug_log,
1120 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1122 (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
1124 return (IV)SvUVX(sv);
1127 else if (SvPOKp(sv) && SvLEN(sv)) {
1128 I32 numtype = looks_like_number(sv);
1130 /* We want to avoid a possible problem when we cache an IV which
1131 may be later translated to an NV, and the resulting NV is not
1132 the translation of the initial data.
1134 This means that if we cache such an IV, we need to cache the
1135 NV as well. Moreover, we trade speed for space, and do not
1136 cache the NV if not needed.
1138 if (numtype & IS_NUMBER_NOT_IV) {
1139 /* May be not an integer. Need to cache NV if we cache IV
1140 * - otherwise future conversion to NV will be wrong. */
1143 d = Atof(SvPVX(sv));
1145 if (SvTYPE(sv) < SVt_PVNV)
1146 sv_upgrade(sv, SVt_PVNV);
1150 #if defined(USE_LONG_DOUBLE)
1151 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1152 (unsigned long)sv, SvNVX(sv)));
1154 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1155 (unsigned long)sv, SvNVX(sv)));
1157 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1158 SvIVX(sv) = I_V(SvNVX(sv));
1160 SvUVX(sv) = U_V(SvNVX(sv));
1166 /* The NV may be reconstructed from IV - safe to cache IV,
1167 which may be calculated by atol(). */
1168 if (SvTYPE(sv) == SVt_PV)
1169 sv_upgrade(sv, SVt_PVIV);
1171 SvIVX(sv) = Atol(SvPVX(sv));
1173 else { /* Not a number. Cache 0. */
1176 if (SvTYPE(sv) < SVt_PVIV)
1177 sv_upgrade(sv, SVt_PVIV);
1180 if (ckWARN(WARN_NUMERIC))
1186 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1187 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1188 if (SvTYPE(sv) < SVt_IV)
1189 /* Typically the caller expects that sv_any is not NULL now. */
1190 sv_upgrade(sv, SVt_IV);
1193 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1194 (unsigned long)sv,(long)SvIVX(sv)));
1195 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1199 Perl_sv_2uv(pTHX_ register SV *sv)
1203 if (SvGMAGICAL(sv)) {
1208 return U_V(SvNVX(sv));
1209 if (SvPOKp(sv) && SvLEN(sv))
1212 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1214 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1215 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1220 if (SvTHINKFIRST(sv)) {
1223 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1224 return SvUV(tmpstr);
1225 return (UV)SvRV(sv);
1227 if (SvREADONLY(sv) && !SvOK(sv)) {
1229 if (ckWARN(WARN_UNINITIALIZED))
1230 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1239 return (UV)SvIVX(sv);
1243 /* We can cache the IV/UV value even if it not good enough
1244 * to reconstruct NV, since the conversion to PV will prefer
1247 if (SvTYPE(sv) == SVt_NV)
1248 sv_upgrade(sv, SVt_PVNV);
1250 if (SvNVX(sv) >= -0.5) {
1252 SvUVX(sv) = U_V(SvNVX(sv));
1255 SvIVX(sv) = I_V(SvNVX(sv));
1258 DEBUG_c(PerlIO_printf(Perl_debug_log,
1259 "0x%" PERL_PRIx64 " 2uv(%" PERL_PRId64 " => %" PERL_PRIu64 ") (as signed)\n",
1260 (unsigned long)sv,(long)SvIVX(sv),
1261 (long)(UV)SvIVX(sv)));
1263 DEBUG_c(PerlIO_printf(Perl_debug_log,
1264 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1265 (unsigned long)sv,(long)SvIVX(sv),
1266 (long)(UV)SvIVX(sv)));
1268 return (UV)SvIVX(sv);
1271 else if (SvPOKp(sv) && SvLEN(sv)) {
1272 I32 numtype = looks_like_number(sv);
1274 /* We want to avoid a possible problem when we cache a UV which
1275 may be later translated to an NV, and the resulting NV is not
1276 the translation of the initial data.
1278 This means that if we cache such a UV, we need to cache the
1279 NV as well. Moreover, we trade speed for space, and do not
1280 cache the NV if not needed.
1282 if (numtype & IS_NUMBER_NOT_IV) {
1283 /* May be not an integer. Need to cache NV if we cache IV
1284 * - otherwise future conversion to NV will be wrong. */
1287 d = Atof(SvPVX(sv));
1289 if (SvTYPE(sv) < SVt_PVNV)
1290 sv_upgrade(sv, SVt_PVNV);
1294 #if defined(USE_LONG_DOUBLE)
1295 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1296 (unsigned long)sv, SvNVX(sv)));
1298 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1299 (unsigned long)sv, SvNVX(sv)));
1301 if (SvNVX(sv) < -0.5) {
1302 SvIVX(sv) = I_V(SvNVX(sv));
1305 SvUVX(sv) = U_V(SvNVX(sv));
1309 else if (numtype & IS_NUMBER_NEG) {
1310 /* The NV may be reconstructed from IV - safe to cache IV,
1311 which may be calculated by atol(). */
1312 if (SvTYPE(sv) == SVt_PV)
1313 sv_upgrade(sv, SVt_PVIV);
1315 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1317 else if (numtype) { /* Non-negative */
1318 /* The NV may be reconstructed from UV - safe to cache UV,
1319 which may be calculated by strtoul()/atol. */
1320 if (SvTYPE(sv) == SVt_PV)
1321 sv_upgrade(sv, SVt_PVIV);
1323 (void)SvIsUV_on(sv);
1325 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1326 #else /* no atou(), but we know the number fits into IV... */
1327 /* The only problem may be if it is negative... */
1328 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1331 else { /* Not a number. Cache 0. */
1334 if (SvTYPE(sv) < SVt_PVIV)
1335 sv_upgrade(sv, SVt_PVIV);
1336 SvUVX(sv) = 0; /* We assume that 0s have the
1337 same bitmap in IV and UV. */
1339 (void)SvIsUV_on(sv);
1340 if (ckWARN(WARN_NUMERIC))
1345 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1347 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1348 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1350 if (SvTYPE(sv) < SVt_IV)
1351 /* Typically the caller expects that sv_any is not NULL now. */
1352 sv_upgrade(sv, SVt_IV);
1356 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1357 (unsigned long)sv,SvUVX(sv)));
1358 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1362 Perl_sv_2nv(pTHX_ register SV *sv)
1366 if (SvGMAGICAL(sv)) {
1370 if (SvPOKp(sv) && SvLEN(sv)) {
1372 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1374 return Atof(SvPVX(sv));
1378 return (NV)SvUVX(sv);
1380 return (NV)SvIVX(sv);
1383 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1385 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1386 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1391 if (SvTHINKFIRST(sv)) {
1394 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1395 return SvNV(tmpstr);
1396 return (NV)(unsigned long)SvRV(sv);
1398 if (SvREADONLY(sv) && !SvOK(sv)) {
1400 if (ckWARN(WARN_UNINITIALIZED))
1401 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1405 if (SvTYPE(sv) < SVt_NV) {
1406 if (SvTYPE(sv) == SVt_IV)
1407 sv_upgrade(sv, SVt_PVNV);
1409 sv_upgrade(sv, SVt_NV);
1410 #if defined(USE_LONG_DOUBLE)
1412 RESTORE_NUMERIC_STANDARD();
1413 PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIgldbl ")\n",
1414 (unsigned long)sv, SvNVX(sv));
1415 RESTORE_NUMERIC_LOCAL();
1419 RESTORE_NUMERIC_STANDARD();
1420 PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
1421 (unsigned long)sv, SvNVX(sv));
1422 RESTORE_NUMERIC_LOCAL();
1426 else if (SvTYPE(sv) < SVt_PVNV)
1427 sv_upgrade(sv, SVt_PVNV);
1429 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1431 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1433 else if (SvPOKp(sv) && SvLEN(sv)) {
1435 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1437 SvNVX(sv) = Atof(SvPVX(sv));
1441 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1442 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1443 if (SvTYPE(sv) < SVt_NV)
1444 /* Typically the caller expects that sv_any is not NULL now. */
1445 sv_upgrade(sv, SVt_NV);
1449 #if defined(USE_LONG_DOUBLE)
1451 RESTORE_NUMERIC_STANDARD();
1452 PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1453 (unsigned long)sv, SvNVX(sv));
1454 RESTORE_NUMERIC_LOCAL();
1458 RESTORE_NUMERIC_STANDARD();
1459 PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
1460 (unsigned long)sv, SvNVX(sv));
1461 RESTORE_NUMERIC_LOCAL();
1468 S_asIV(pTHX_ SV *sv)
1470 I32 numtype = looks_like_number(sv);
1473 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1474 return Atol(SvPVX(sv));
1477 if (ckWARN(WARN_NUMERIC))
1480 d = Atof(SvPVX(sv));
1485 S_asUV(pTHX_ SV *sv)
1487 I32 numtype = looks_like_number(sv);
1490 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1491 return Strtoul(SvPVX(sv), Null(char**), 10);
1495 if (ckWARN(WARN_NUMERIC))
1498 return U_V(Atof(SvPVX(sv)));
1502 * Returns a combination of (advisory only - can get false negatives)
1503 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1505 * 0 if does not look like number.
1507 * In fact possible values are 0 and
1508 * IS_NUMBER_TO_INT_BY_ATOL 123
1509 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1510 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1511 * with a possible addition of IS_NUMBER_NEG.
1515 Perl_looks_like_number(pTHX_ SV *sv)
1518 register char *send;
1519 register char *sbegin;
1520 register char *nbegin;
1528 else if (SvPOKp(sv))
1529 sbegin = SvPV(sv, len);
1532 send = sbegin + len;
1539 numtype = IS_NUMBER_NEG;
1546 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1547 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1551 /* next must be digit or the radix separator */
1555 } while (isDIGIT(*s));
1557 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1558 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1560 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1563 #ifdef USE_LOCALE_NUMERIC
1564 || IS_NUMERIC_RADIX(*s)
1568 numtype |= IS_NUMBER_NOT_IV;
1569 while (isDIGIT(*s)) /* optional digits after the radix */
1574 #ifdef USE_LOCALE_NUMERIC
1575 || IS_NUMERIC_RADIX(*s)
1579 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1580 /* no digits before the radix means we need digits after it */
1584 } while (isDIGIT(*s));
1592 /* we can have an optional exponent part */
1593 if (*s == 'e' || *s == 'E') {
1594 numtype &= ~IS_NUMBER_NEG;
1595 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1597 if (*s == '+' || *s == '-')
1602 } while (isDIGIT(*s));
1611 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1612 return IS_NUMBER_TO_INT_BY_ATOL;
1617 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1620 return sv_2pv(sv, &n_a);
1623 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1625 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1628 char *ptr = buf + TYPE_CHARS(UV);
1643 *--ptr = '0' + (uv % 10);
1652 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1657 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1658 char *tmpbuf = tbuf;
1664 if (SvGMAGICAL(sv)) {
1673 (void)sprintf(tmpbuf,"%" PERL_PRIu64,(UV)SvUVX(sv));
1675 (void)sprintf(tmpbuf,"%" PERL_PRId64,(IV)SvIVX(sv));
1678 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1680 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1686 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
1691 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1693 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1694 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1700 if (SvTHINKFIRST(sv)) {
1703 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1704 return SvPV(tmpstr,*lp);
1711 switch (SvTYPE(sv)) {
1713 if ( ((SvFLAGS(sv) &
1714 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1715 == (SVs_OBJECT|SVs_RMG))
1716 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1717 && (mg = mg_find(sv, 'r'))) {
1719 regexp *re = (regexp *)mg->mg_obj;
1722 char *fptr = "msix";
1727 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1729 while(ch = *fptr++) {
1731 reflags[left++] = ch;
1734 reflags[right--] = ch;
1739 reflags[left] = '-';
1743 mg->mg_len = re->prelen + 4 + left;
1744 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1745 Copy("(?", mg->mg_ptr, 2, char);
1746 Copy(reflags, mg->mg_ptr+2, left, char);
1747 Copy(":", mg->mg_ptr+left+2, 1, char);
1748 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1749 mg->mg_ptr[mg->mg_len - 1] = ')';
1750 mg->mg_ptr[mg->mg_len] = 0;
1752 PL_reginterp_cnt += re->program[0].next_off;
1764 case SVt_PVBM: s = "SCALAR"; break;
1765 case SVt_PVLV: s = "LVALUE"; break;
1766 case SVt_PVAV: s = "ARRAY"; break;
1767 case SVt_PVHV: s = "HASH"; break;
1768 case SVt_PVCV: s = "CODE"; break;
1769 case SVt_PVGV: s = "GLOB"; break;
1770 case SVt_PVFM: s = "FORMAT"; break;
1771 case SVt_PVIO: s = "IO"; break;
1772 default: s = "UNKNOWN"; break;
1776 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1780 Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", (UV)sv);
1782 Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
1789 if (SvREADONLY(sv) && !SvOK(sv)) {
1791 if (ckWARN(WARN_UNINITIALIZED))
1792 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1797 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1798 /* XXXX 64-bit? IV may have better precision... */
1799 if (SvTYPE(sv) < SVt_PVNV)
1800 sv_upgrade(sv, SVt_PVNV);
1803 olderrno = errno; /* some Xenix systems wipe out errno here */
1805 if (SvNVX(sv) == 0.0)
1806 (void)strcpy(s,"0");
1810 Gconvert(SvNVX(sv), NV_DIG, 0, s);
1813 #ifdef FIXNEGATIVEZERO
1814 if (*s == '-' && s[1] == '0' && !s[2])
1823 else if (SvIOKp(sv)) {
1824 U32 isIOK = SvIOK(sv);
1825 U32 isUIOK = SvIsUV(sv);
1826 char buf[TYPE_CHARS(UV)];
1829 if (SvTYPE(sv) < SVt_PVIV)
1830 sv_upgrade(sv, SVt_PVIV);
1832 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1834 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1835 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
1836 Move(ptr,SvPVX(sv),ebuf - ptr,char);
1837 SvCUR_set(sv, ebuf - ptr);
1850 if (ckWARN(WARN_UNINITIALIZED)
1851 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1853 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1856 if (SvTYPE(sv) < SVt_PV)
1857 /* Typically the caller expects that sv_any is not NULL now. */
1858 sv_upgrade(sv, SVt_PV);
1861 *lp = s - SvPVX(sv);
1864 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
1865 (unsigned long)sv,SvPVX(sv)));
1869 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1870 /* Sneaky stuff here */
1874 tsv = newSVpv(tmpbuf, 0);
1890 len = strlen(tmpbuf);
1892 #ifdef FIXNEGATIVEZERO
1893 if (len == 2 && t[0] == '-' && t[1] == '0') {
1898 (void)SvUPGRADE(sv, SVt_PV);
1900 s = SvGROW(sv, len + 1);
1908 /* This function is only called on magical items */
1910 Perl_sv_2bool(pTHX_ register SV *sv)
1920 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1921 return SvTRUE(tmpsv);
1922 return SvRV(sv) != 0;
1925 register XPV* Xpvtmp;
1926 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1927 (*Xpvtmp->xpv_pv > '0' ||
1928 Xpvtmp->xpv_cur > 1 ||
1929 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
1936 return SvIVX(sv) != 0;
1939 return SvNVX(sv) != 0.0;
1946 /* Note: sv_setsv() should not be called with a source string that needs
1947 * to be reused, since it may destroy the source string if it is marked
1952 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
1955 register U32 sflags;
1961 SV_CHECK_THINKFIRST(dstr);
1963 sstr = &PL_sv_undef;
1964 stype = SvTYPE(sstr);
1965 dtype = SvTYPE(dstr);
1969 /* There's a lot of redundancy below but we're going for speed here */
1974 if (dtype != SVt_PVGV) {
1975 (void)SvOK_off(dstr);
1983 sv_upgrade(dstr, SVt_IV);
1986 sv_upgrade(dstr, SVt_PVNV);
1990 sv_upgrade(dstr, SVt_PVIV);
1993 (void)SvIOK_only(dstr);
1994 SvIVX(dstr) = SvIVX(sstr);
2007 sv_upgrade(dstr, SVt_NV);
2012 sv_upgrade(dstr, SVt_PVNV);
2015 SvNVX(dstr) = SvNVX(sstr);
2016 (void)SvNOK_only(dstr);
2024 sv_upgrade(dstr, SVt_RV);
2025 else if (dtype == SVt_PVGV &&
2026 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2029 if (PL_curcop->cop_stash != GvSTASH(dstr))
2030 GvIMPORTED_on(dstr);
2040 sv_upgrade(dstr, SVt_PV);
2043 if (dtype < SVt_PVIV)
2044 sv_upgrade(dstr, SVt_PVIV);
2047 if (dtype < SVt_PVNV)
2048 sv_upgrade(dstr, SVt_PVNV);
2055 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2056 PL_op_name[PL_op->op_type]);
2058 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2062 if (dtype <= SVt_PVGV) {
2064 if (dtype != SVt_PVGV) {
2065 char *name = GvNAME(sstr);
2066 STRLEN len = GvNAMELEN(sstr);
2067 sv_upgrade(dstr, SVt_PVGV);
2068 sv_magic(dstr, dstr, '*', name, len);
2069 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2070 GvNAME(dstr) = savepvn(name, len);
2071 GvNAMELEN(dstr) = len;
2072 SvFAKE_on(dstr); /* can coerce to non-glob */
2074 /* ahem, death to those who redefine active sort subs */
2075 else if (PL_curstackinfo->si_type == PERLSI_SORT
2076 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2077 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2079 (void)SvOK_off(dstr);
2080 GvINTRO_off(dstr); /* one-shot flag */
2082 GvGP(dstr) = gp_ref(GvGP(sstr));
2084 if (PL_curcop->cop_stash != GvSTASH(dstr))
2085 GvIMPORTED_on(dstr);
2092 if (SvGMAGICAL(sstr)) {
2094 if (SvTYPE(sstr) != stype) {
2095 stype = SvTYPE(sstr);
2096 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2100 if (stype == SVt_PVLV)
2101 (void)SvUPGRADE(dstr, SVt_PVNV);
2103 (void)SvUPGRADE(dstr, stype);
2106 sflags = SvFLAGS(sstr);
2108 if (sflags & SVf_ROK) {
2109 if (dtype >= SVt_PV) {
2110 if (dtype == SVt_PVGV) {
2111 SV *sref = SvREFCNT_inc(SvRV(sstr));
2113 int intro = GvINTRO(dstr);
2117 GvGP(dstr)->gp_refcnt--;
2118 GvINTRO_off(dstr); /* one-shot flag */
2119 Newz(602,gp, 1, GP);
2120 GvGP(dstr) = gp_ref(gp);
2121 GvSV(dstr) = NEWSV(72,0);
2122 GvLINE(dstr) = PL_curcop->cop_line;
2123 GvEGV(dstr) = (GV*)dstr;
2126 switch (SvTYPE(sref)) {
2129 SAVESPTR(GvAV(dstr));
2131 dref = (SV*)GvAV(dstr);
2132 GvAV(dstr) = (AV*)sref;
2133 if (PL_curcop->cop_stash != GvSTASH(dstr))
2134 GvIMPORTED_AV_on(dstr);
2138 SAVESPTR(GvHV(dstr));
2140 dref = (SV*)GvHV(dstr);
2141 GvHV(dstr) = (HV*)sref;
2142 if (PL_curcop->cop_stash != GvSTASH(dstr))
2143 GvIMPORTED_HV_on(dstr);
2147 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2148 SvREFCNT_dec(GvCV(dstr));
2149 GvCV(dstr) = Nullcv;
2150 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2151 PL_sub_generation++;
2153 SAVESPTR(GvCV(dstr));
2156 dref = (SV*)GvCV(dstr);
2157 if (GvCV(dstr) != (CV*)sref) {
2158 CV* cv = GvCV(dstr);
2160 if (!GvCVGEN((GV*)dstr) &&
2161 (CvROOT(cv) || CvXSUB(cv)))
2163 SV *const_sv = cv_const_sv(cv);
2164 bool const_changed = TRUE;
2166 const_changed = sv_cmp(const_sv,
2167 op_const_sv(CvSTART((CV*)sref),
2169 /* ahem, death to those who redefine
2170 * active sort subs */
2171 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2172 PL_sortcop == CvSTART(cv))
2174 "Can't redefine active sort subroutine %s",
2175 GvENAME((GV*)dstr));
2176 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2177 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2178 && HvNAME(GvSTASH(CvGV(cv)))
2179 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2181 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2182 "Constant subroutine %s redefined"
2183 : "Subroutine %s redefined",
2184 GvENAME((GV*)dstr));
2187 cv_ckproto(cv, (GV*)dstr,
2188 SvPOK(sref) ? SvPVX(sref) : Nullch);
2190 GvCV(dstr) = (CV*)sref;
2191 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2192 GvASSUMECV_on(dstr);
2193 PL_sub_generation++;
2195 if (PL_curcop->cop_stash != GvSTASH(dstr))
2196 GvIMPORTED_CV_on(dstr);
2200 SAVESPTR(GvIOp(dstr));
2202 dref = (SV*)GvIOp(dstr);
2203 GvIOp(dstr) = (IO*)sref;
2207 SAVESPTR(GvSV(dstr));
2209 dref = (SV*)GvSV(dstr);
2211 if (PL_curcop->cop_stash != GvSTASH(dstr))
2212 GvIMPORTED_SV_on(dstr);
2223 (void)SvOOK_off(dstr); /* backoff */
2225 Safefree(SvPVX(dstr));
2226 SvLEN(dstr)=SvCUR(dstr)=0;
2229 (void)SvOK_off(dstr);
2230 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2232 if (sflags & SVp_NOK) {
2234 SvNVX(dstr) = SvNVX(sstr);
2236 if (sflags & SVp_IOK) {
2237 (void)SvIOK_on(dstr);
2238 SvIVX(dstr) = SvIVX(sstr);
2242 if (SvAMAGIC(sstr)) {
2246 else if (sflags & SVp_POK) {
2249 * Check to see if we can just swipe the string. If so, it's a
2250 * possible small lose on short strings, but a big win on long ones.
2251 * It might even be a win on short strings if SvPVX(dstr)
2252 * has to be allocated and SvPVX(sstr) has to be freed.
2255 if (SvTEMP(sstr) && /* slated for free anyway? */
2256 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2257 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2259 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2261 SvFLAGS(dstr) &= ~SVf_OOK;
2262 Safefree(SvPVX(dstr) - SvIVX(dstr));
2264 else if (SvLEN(dstr))
2265 Safefree(SvPVX(dstr));
2267 (void)SvPOK_only(dstr);
2268 SvPV_set(dstr, SvPVX(sstr));
2269 SvLEN_set(dstr, SvLEN(sstr));
2270 SvCUR_set(dstr, SvCUR(sstr));
2272 (void)SvOK_off(sstr);
2273 SvPV_set(sstr, Nullch);
2278 else { /* have to copy actual string */
2279 STRLEN len = SvCUR(sstr);
2281 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2282 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2283 SvCUR_set(dstr, len);
2284 *SvEND(dstr) = '\0';
2285 (void)SvPOK_only(dstr);
2288 if (sflags & SVp_NOK) {
2290 SvNVX(dstr) = SvNVX(sstr);
2292 if (sflags & SVp_IOK) {
2293 (void)SvIOK_on(dstr);
2294 SvIVX(dstr) = SvIVX(sstr);
2299 else if (sflags & SVp_NOK) {
2300 SvNVX(dstr) = SvNVX(sstr);
2301 (void)SvNOK_only(dstr);
2303 (void)SvIOK_on(dstr);
2304 SvIVX(dstr) = SvIVX(sstr);
2305 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2310 else if (sflags & SVp_IOK) {
2311 (void)SvIOK_only(dstr);
2312 SvIVX(dstr) = SvIVX(sstr);
2317 if (dtype == SVt_PVGV) {
2318 if (ckWARN(WARN_UNSAFE))
2319 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2322 (void)SvOK_off(dstr);
2328 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2330 sv_setsv(dstr,sstr);
2335 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2337 register char *dptr;
2338 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2339 elicit a warning, but it won't hurt. */
2340 SV_CHECK_THINKFIRST(sv);
2345 (void)SvUPGRADE(sv, SVt_PV);
2347 SvGROW(sv, len + 1);
2349 Move(ptr,dptr,len,char);
2352 (void)SvPOK_only(sv); /* validate pointer */
2357 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2359 sv_setpvn(sv,ptr,len);
2364 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2366 register STRLEN len;
2368 SV_CHECK_THINKFIRST(sv);
2374 (void)SvUPGRADE(sv, SVt_PV);
2376 SvGROW(sv, len + 1);
2377 Move(ptr,SvPVX(sv),len+1,char);
2379 (void)SvPOK_only(sv); /* validate pointer */
2384 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2391 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2393 SV_CHECK_THINKFIRST(sv);
2394 (void)SvUPGRADE(sv, SVt_PV);
2399 (void)SvOOK_off(sv);
2400 if (SvPVX(sv) && SvLEN(sv))
2401 Safefree(SvPVX(sv));
2402 Renew(ptr, len+1, char);
2405 SvLEN_set(sv, len+1);
2407 (void)SvPOK_only(sv); /* validate pointer */
2412 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2414 sv_usepvn(sv,ptr,len);
2419 Perl_sv_force_normal(pTHX_ register SV *sv)
2421 if (SvREADONLY(sv)) {
2423 if (PL_curcop != &PL_compiling)
2424 Perl_croak(aTHX_ PL_no_modify);
2428 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2433 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2437 register STRLEN delta;
2439 if (!ptr || !SvPOKp(sv))
2441 SV_CHECK_THINKFIRST(sv);
2442 if (SvTYPE(sv) < SVt_PVIV)
2443 sv_upgrade(sv,SVt_PVIV);
2446 if (!SvLEN(sv)) { /* make copy of shared string */
2447 char *pvx = SvPVX(sv);
2448 STRLEN len = SvCUR(sv);
2449 SvGROW(sv, len + 1);
2450 Move(pvx,SvPVX(sv),len,char);
2454 SvFLAGS(sv) |= SVf_OOK;
2456 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2457 delta = ptr - SvPVX(sv);
2465 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2470 junk = SvPV_force(sv, tlen);
2471 SvGROW(sv, tlen + len + 1);
2474 Move(ptr,SvPVX(sv)+tlen,len,char);
2477 (void)SvPOK_only(sv); /* validate pointer */
2482 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2484 sv_catpvn(sv,ptr,len);
2489 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2495 if (s = SvPV(sstr, len))
2496 sv_catpvn(dstr,s,len);
2500 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2502 sv_catsv(dstr,sstr);
2507 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2509 register STRLEN len;
2515 junk = SvPV_force(sv, tlen);
2517 SvGROW(sv, tlen + len + 1);
2520 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2522 (void)SvPOK_only(sv); /* validate pointer */
2527 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2534 Perl_newSV(pTHX_ STRLEN len)
2540 sv_upgrade(sv, SVt_PV);
2541 SvGROW(sv, len + 1);
2546 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2549 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2553 if (SvREADONLY(sv)) {
2555 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2556 Perl_croak(aTHX_ PL_no_modify);
2558 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2559 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2566 (void)SvUPGRADE(sv, SVt_PVMG);
2568 Newz(702,mg, 1, MAGIC);
2569 mg->mg_moremagic = SvMAGIC(sv);
2572 if (!obj || obj == sv || how == '#' || how == 'r')
2576 mg->mg_obj = SvREFCNT_inc(obj);
2577 mg->mg_flags |= MGf_REFCOUNTED;
2580 mg->mg_len = namlen;
2583 mg->mg_ptr = savepvn(name, namlen);
2584 else if (namlen == HEf_SVKEY)
2585 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2589 mg->mg_virtual = &PL_vtbl_sv;
2592 mg->mg_virtual = &PL_vtbl_amagic;
2595 mg->mg_virtual = &PL_vtbl_amagicelem;
2601 mg->mg_virtual = &PL_vtbl_bm;
2604 mg->mg_virtual = &PL_vtbl_regdata;
2607 mg->mg_virtual = &PL_vtbl_regdatum;
2610 mg->mg_virtual = &PL_vtbl_env;
2613 mg->mg_virtual = &PL_vtbl_fm;
2616 mg->mg_virtual = &PL_vtbl_envelem;
2619 mg->mg_virtual = &PL_vtbl_mglob;
2622 mg->mg_virtual = &PL_vtbl_isa;
2625 mg->mg_virtual = &PL_vtbl_isaelem;
2628 mg->mg_virtual = &PL_vtbl_nkeys;
2635 mg->mg_virtual = &PL_vtbl_dbline;
2639 mg->mg_virtual = &PL_vtbl_mutex;
2641 #endif /* USE_THREADS */
2642 #ifdef USE_LOCALE_COLLATE
2644 mg->mg_virtual = &PL_vtbl_collxfrm;
2646 #endif /* USE_LOCALE_COLLATE */
2648 mg->mg_virtual = &PL_vtbl_pack;
2652 mg->mg_virtual = &PL_vtbl_packelem;
2655 mg->mg_virtual = &PL_vtbl_regexp;
2658 mg->mg_virtual = &PL_vtbl_sig;
2661 mg->mg_virtual = &PL_vtbl_sigelem;
2664 mg->mg_virtual = &PL_vtbl_taint;
2668 mg->mg_virtual = &PL_vtbl_uvar;
2671 mg->mg_virtual = &PL_vtbl_vec;
2674 mg->mg_virtual = &PL_vtbl_substr;
2677 mg->mg_virtual = &PL_vtbl_defelem;
2680 mg->mg_virtual = &PL_vtbl_glob;
2683 mg->mg_virtual = &PL_vtbl_arylen;
2686 mg->mg_virtual = &PL_vtbl_pos;
2689 mg->mg_virtual = &PL_vtbl_backref;
2691 case '~': /* Reserved for use by extensions not perl internals. */
2692 /* Useful for attaching extension internal data to perl vars. */
2693 /* Note that multiple extensions may clash if magical scalars */
2694 /* etc holding private data from one are passed to another. */
2698 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
2702 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2706 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2710 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2713 for (mg = *mgp; mg; mg = *mgp) {
2714 if (mg->mg_type == type) {
2715 MGVTBL* vtbl = mg->mg_virtual;
2716 *mgp = mg->mg_moremagic;
2717 if (vtbl && (vtbl->svt_free != NULL))
2718 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
2719 if (mg->mg_ptr && mg->mg_type != 'g')
2720 if (mg->mg_len >= 0)
2721 Safefree(mg->mg_ptr);
2722 else if (mg->mg_len == HEf_SVKEY)
2723 SvREFCNT_dec((SV*)mg->mg_ptr);
2724 if (mg->mg_flags & MGf_REFCOUNTED)
2725 SvREFCNT_dec(mg->mg_obj);
2729 mgp = &mg->mg_moremagic;
2733 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2740 Perl_sv_rvweaken(pTHX_ SV *sv)
2743 if (!SvOK(sv)) /* let undefs pass */
2746 Perl_croak(aTHX_ "Can't weaken a nonreference");
2747 else if (SvWEAKREF(sv)) {
2749 if (ckWARN(WARN_MISC))
2750 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
2754 sv_add_backref(tsv, sv);
2761 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
2765 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2766 av = (AV*)mg->mg_obj;
2769 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2770 SvREFCNT_dec(av); /* for sv_magic */
2776 S_sv_del_backref(pTHX_ SV *sv)
2783 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2784 Perl_croak(aTHX_ "panic: del_backref");
2785 av = (AV *)mg->mg_obj;
2790 svp[i] = &PL_sv_undef; /* XXX */
2797 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2801 register char *midend;
2802 register char *bigend;
2808 Perl_croak(aTHX_ "Can't modify non-existent substring");
2809 SvPV_force(bigstr, curlen);
2810 if (offset + len > curlen) {
2811 SvGROW(bigstr, offset+len+1);
2812 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2813 SvCUR_set(bigstr, offset+len);
2816 i = littlelen - len;
2817 if (i > 0) { /* string might grow */
2818 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2819 mid = big + offset + len;
2820 midend = bigend = big + SvCUR(bigstr);
2823 while (midend > mid) /* shove everything down */
2824 *--bigend = *--midend;
2825 Move(little,big+offset,littlelen,char);
2831 Move(little,SvPVX(bigstr)+offset,len,char);
2836 big = SvPVX(bigstr);
2839 bigend = big + SvCUR(bigstr);
2841 if (midend > bigend)
2842 Perl_croak(aTHX_ "panic: sv_insert");
2844 if (mid - big > bigend - midend) { /* faster to shorten from end */
2846 Move(little, mid, littlelen,char);
2849 i = bigend - midend;
2851 Move(midend, mid, i,char);
2855 SvCUR_set(bigstr, mid - big);
2858 else if (i = mid - big) { /* faster from front */
2859 midend -= littlelen;
2861 sv_chop(bigstr,midend-i);
2866 Move(little, mid, littlelen,char);
2868 else if (littlelen) {
2869 midend -= littlelen;
2870 sv_chop(bigstr,midend);
2871 Move(little,midend,littlelen,char);
2874 sv_chop(bigstr,midend);
2879 /* make sv point to what nstr did */
2882 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2885 U32 refcnt = SvREFCNT(sv);
2886 SV_CHECK_THINKFIRST(sv);
2887 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
2888 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
2889 if (SvMAGICAL(sv)) {
2893 sv_upgrade(nsv, SVt_PVMG);
2894 SvMAGIC(nsv) = SvMAGIC(sv);
2895 SvFLAGS(nsv) |= SvMAGICAL(sv);
2901 assert(!SvREFCNT(sv));
2902 StructCopy(nsv,sv,SV);
2903 SvREFCNT(sv) = refcnt;
2904 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2909 Perl_sv_clear(pTHX_ register SV *sv)
2913 assert(SvREFCNT(sv) == 0);
2917 if (PL_defstash) { /* Still have a symbol table? */
2922 Zero(&tmpref, 1, SV);
2923 sv_upgrade(&tmpref, SVt_RV);
2925 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
2926 SvREFCNT(&tmpref) = 1;
2929 stash = SvSTASH(sv);
2930 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2933 PUSHSTACKi(PERLSI_DESTROY);
2934 SvRV(&tmpref) = SvREFCNT_inc(sv);
2939 call_sv((SV*)GvCV(destructor),
2940 G_DISCARD|G_EVAL|G_KEEPERR);
2946 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
2948 del_XRV(SvANY(&tmpref));
2951 if (PL_in_clean_objs)
2952 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
2954 /* DESTROY gave object new lease on life */
2960 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
2961 SvOBJECT_off(sv); /* Curse the object. */
2962 if (SvTYPE(sv) != SVt_PVIO)
2963 --PL_sv_objcount; /* XXX Might want something more general */
2966 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2969 switch (SvTYPE(sv)) {
2972 IoIFP(sv) != PerlIO_stdin() &&
2973 IoIFP(sv) != PerlIO_stdout() &&
2974 IoIFP(sv) != PerlIO_stderr())
2976 io_close((IO*)sv, FALSE);
2979 PerlDir_close(IoDIRP(sv));
2982 Safefree(IoTOP_NAME(sv));
2983 Safefree(IoFMT_NAME(sv));
2984 Safefree(IoBOTTOM_NAME(sv));
2999 SvREFCNT_dec(LvTARG(sv));
3003 Safefree(GvNAME(sv));
3004 /* cannot decrease stash refcount yet, as we might recursively delete
3005 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3006 of stash until current sv is completely gone.
3007 -- JohnPC, 27 Mar 1998 */
3008 stash = GvSTASH(sv);
3014 (void)SvOOK_off(sv);
3022 SvREFCNT_dec(SvRV(sv));
3024 else if (SvPVX(sv) && SvLEN(sv))
3025 Safefree(SvPVX(sv));
3035 switch (SvTYPE(sv)) {
3051 del_XPVIV(SvANY(sv));
3054 del_XPVNV(SvANY(sv));
3057 del_XPVMG(SvANY(sv));
3060 del_XPVLV(SvANY(sv));
3063 del_XPVAV(SvANY(sv));
3066 del_XPVHV(SvANY(sv));
3069 del_XPVCV(SvANY(sv));
3072 del_XPVGV(SvANY(sv));
3073 /* code duplication for increased performance. */
3074 SvFLAGS(sv) &= SVf_BREAK;
3075 SvFLAGS(sv) |= SVTYPEMASK;
3076 /* decrease refcount of the stash that owns this GV, if any */
3078 SvREFCNT_dec(stash);
3079 return; /* not break, SvFLAGS reset already happened */
3081 del_XPVBM(SvANY(sv));
3084 del_XPVFM(SvANY(sv));
3087 del_XPVIO(SvANY(sv));
3090 SvFLAGS(sv) &= SVf_BREAK;
3091 SvFLAGS(sv) |= SVTYPEMASK;
3095 Perl_sv_newref(pTHX_ SV *sv)
3098 ATOMIC_INC(SvREFCNT(sv));
3103 Perl_sv_free(pTHX_ SV *sv)
3106 int refcount_is_zero;
3110 if (SvREFCNT(sv) == 0) {
3111 if (SvFLAGS(sv) & SVf_BREAK)
3113 if (PL_in_clean_all) /* All is fair */
3115 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3116 /* make sure SvREFCNT(sv)==0 happens very seldom */
3117 SvREFCNT(sv) = (~(U32)0)/2;
3120 if (ckWARN_d(WARN_INTERNAL))
3121 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3124 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3125 if (!refcount_is_zero)
3129 if (ckWARN_d(WARN_DEBUGGING))
3130 Perl_warner(aTHX_ WARN_DEBUGGING,
3131 "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3135 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3136 /* make sure SvREFCNT(sv)==0 happens very seldom */
3137 SvREFCNT(sv) = (~(U32)0)/2;
3146 Perl_sv_len(pTHX_ register SV *sv)
3155 len = mg_length(sv);
3157 junk = SvPV(sv, len);
3162 Perl_sv_len_utf8(pTHX_ register SV *sv)
3173 len = mg_length(sv);
3176 s = (U8*)SvPV(sv, len);
3187 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3192 I32 uoffset = *offsetp;
3198 start = s = (U8*)SvPV(sv, len);
3200 while (s < send && uoffset--)
3204 *offsetp = s - start;
3208 while (s < send && ulen--)
3218 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3227 s = (U8*)SvPV(sv, len);
3229 Perl_croak(aTHX_ "panic: bad byte offset");
3230 send = s + *offsetp;
3238 if (ckWARN_d(WARN_UTF8))
3239 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3247 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3259 pv1 = SvPV(str1, cur1);
3264 pv2 = SvPV(str2, cur2);
3269 return memEQ(pv1, pv2, cur1);
3273 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3276 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3278 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3282 return cur2 ? -1 : 0;
3287 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3290 return retval < 0 ? -1 : 1;
3295 return cur1 < cur2 ? -1 : 1;
3299 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3301 #ifdef USE_LOCALE_COLLATE
3307 if (PL_collation_standard)
3311 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3313 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3315 if (!pv1 || !len1) {
3326 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3329 return retval < 0 ? -1 : 1;
3332 * When the result of collation is equality, that doesn't mean
3333 * that there are no differences -- some locales exclude some
3334 * characters from consideration. So to avoid false equalities,
3335 * we use the raw string as a tiebreaker.
3341 #endif /* USE_LOCALE_COLLATE */
3343 return sv_cmp(sv1, sv2);
3346 #ifdef USE_LOCALE_COLLATE
3348 * Any scalar variable may carry an 'o' magic that contains the
3349 * scalar data of the variable transformed to such a format that
3350 * a normal memory comparison can be used to compare the data
3351 * according to the locale settings.
3354 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3358 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3359 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3364 Safefree(mg->mg_ptr);
3366 if ((xf = mem_collxfrm(s, len, &xlen))) {
3367 if (SvREADONLY(sv)) {
3370 return xf + sizeof(PL_collation_ix);
3373 sv_magic(sv, 0, 'o', 0, 0);
3374 mg = mg_find(sv, 'o');
3387 if (mg && mg->mg_ptr) {
3389 return mg->mg_ptr + sizeof(PL_collation_ix);
3397 #endif /* USE_LOCALE_COLLATE */
3400 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3405 register STDCHAR rslast;
3406 register STDCHAR *bp;
3410 SV_CHECK_THINKFIRST(sv);
3411 (void)SvUPGRADE(sv, SVt_PV);
3415 if (RsSNARF(PL_rs)) {
3419 else if (RsRECORD(PL_rs)) {
3420 I32 recsize, bytesread;
3423 /* Grab the size of the record we're getting */
3424 recsize = SvIV(SvRV(PL_rs));
3425 (void)SvPOK_only(sv); /* Validate pointer */
3426 buffer = SvGROW(sv, recsize + 1);
3429 /* VMS wants read instead of fread, because fread doesn't respect */
3430 /* RMS record boundaries. This is not necessarily a good thing to be */
3431 /* doing, but we've got no other real choice */
3432 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3434 bytesread = PerlIO_read(fp, buffer, recsize);
3436 SvCUR_set(sv, bytesread);
3437 buffer[bytesread] = '\0';
3438 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3440 else if (RsPARA(PL_rs)) {
3445 rsptr = SvPV(PL_rs, rslen);
3446 rslast = rslen ? rsptr[rslen - 1] : '\0';
3448 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3449 do { /* to make sure file boundaries work right */
3452 i = PerlIO_getc(fp);
3456 PerlIO_ungetc(fp,i);
3462 /* See if we know enough about I/O mechanism to cheat it ! */
3464 /* This used to be #ifdef test - it is made run-time test for ease
3465 of abstracting out stdio interface. One call should be cheap
3466 enough here - and may even be a macro allowing compile
3470 if (PerlIO_fast_gets(fp)) {
3473 * We're going to steal some values from the stdio struct
3474 * and put EVERYTHING in the innermost loop into registers.
3476 register STDCHAR *ptr;
3480 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3481 /* An ungetc()d char is handled separately from the regular
3482 * buffer, so we getc() it back out and stuff it in the buffer.
3484 i = PerlIO_getc(fp);
3485 if (i == EOF) return 0;
3486 *(--((*fp)->_ptr)) = (unsigned char) i;
3490 /* Here is some breathtakingly efficient cheating */
3492 cnt = PerlIO_get_cnt(fp); /* get count into register */
3493 (void)SvPOK_only(sv); /* validate pointer */
3494 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3495 if (cnt > 80 && SvLEN(sv) > append) {
3496 shortbuffered = cnt - SvLEN(sv) + append + 1;
3497 cnt -= shortbuffered;
3501 /* remember that cnt can be negative */
3502 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3507 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3508 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3509 DEBUG_P(PerlIO_printf(Perl_debug_log,
3510 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3511 DEBUG_P(PerlIO_printf(Perl_debug_log,
3512 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3513 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3514 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3519 while (cnt > 0) { /* this | eat */
3521 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3522 goto thats_all_folks; /* screams | sed :-) */
3526 Copy(ptr, bp, cnt, char); /* this | eat */
3527 bp += cnt; /* screams | dust */
3528 ptr += cnt; /* louder | sed :-) */
3533 if (shortbuffered) { /* oh well, must extend */
3534 cnt = shortbuffered;
3536 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3538 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3539 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3543 DEBUG_P(PerlIO_printf(Perl_debug_log,
3544 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3545 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3546 DEBUG_P(PerlIO_printf(Perl_debug_log,
3547 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3548 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3549 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3550 /* This used to call 'filbuf' in stdio form, but as that behaves like
3551 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3552 another abstraction. */
3553 i = PerlIO_getc(fp); /* get more characters */
3554 DEBUG_P(PerlIO_printf(Perl_debug_log,
3555 "Screamer: post: 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)));
3558 cnt = PerlIO_get_cnt(fp);
3559 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3560 DEBUG_P(PerlIO_printf(Perl_debug_log,
3561 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3563 if (i == EOF) /* all done for ever? */
3564 goto thats_really_all_folks;
3566 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3568 SvGROW(sv, bpx + cnt + 2);
3569 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3571 *bp++ = i; /* store character from PerlIO_getc */
3573 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3574 goto thats_all_folks;
3578 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3579 memNE((char*)bp - rslen, rsptr, rslen))
3580 goto screamer; /* go back to the fray */
3581 thats_really_all_folks:
3583 cnt += shortbuffered;
3584 DEBUG_P(PerlIO_printf(Perl_debug_log,
3585 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3586 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3587 DEBUG_P(PerlIO_printf(Perl_debug_log,
3588 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3589 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3590 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3592 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3593 DEBUG_P(PerlIO_printf(Perl_debug_log,
3594 "Screamer: done, len=%ld, string=|%.*s|\n",
3595 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3600 /*The big, slow, and stupid way */
3603 /* Need to work around EPOC SDK features */
3604 /* On WINS: MS VC5 generates calls to _chkstk, */
3605 /* if a `large' stack frame is allocated */
3606 /* gcc on MARM does not generate calls like these */
3612 register STDCHAR *bpe = buf + sizeof(buf);
3614 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3615 ; /* keep reading */
3619 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3620 /* Accomodate broken VAXC compiler, which applies U8 cast to
3621 * both args of ?: operator, causing EOF to change into 255
3623 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3627 sv_catpvn(sv, (char *) buf, cnt);
3629 sv_setpvn(sv, (char *) buf, cnt);
3631 if (i != EOF && /* joy */
3633 SvCUR(sv) < rslen ||
3634 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3638 * If we're reading from a TTY and we get a short read,
3639 * indicating that the user hit his EOF character, we need
3640 * to notice it now, because if we try to read from the TTY
3641 * again, the EOF condition will disappear.
3643 * The comparison of cnt to sizeof(buf) is an optimization
3644 * that prevents unnecessary calls to feof().
3648 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3653 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3654 while (i != EOF) { /* to make sure file boundaries work right */
3655 i = PerlIO_getc(fp);
3657 PerlIO_ungetc(fp,i);
3664 win32_strip_return(sv);
3667 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3672 Perl_sv_inc(pTHX_ register SV *sv)
3681 if (SvTHINKFIRST(sv)) {
3682 if (SvREADONLY(sv)) {
3684 if (PL_curcop != &PL_compiling)
3685 Perl_croak(aTHX_ PL_no_modify);
3689 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3696 flags = SvFLAGS(sv);
3697 if (flags & SVp_NOK) {
3698 (void)SvNOK_only(sv);
3702 if (flags & SVp_IOK) {
3704 if (SvUVX(sv) == UV_MAX)
3705 sv_setnv(sv, (NV)UV_MAX + 1.0);
3707 (void)SvIOK_only_UV(sv);
3710 if (SvIVX(sv) == IV_MAX)
3711 sv_setnv(sv, (NV)IV_MAX + 1.0);
3713 (void)SvIOK_only(sv);
3719 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3720 if ((flags & SVTYPEMASK) < SVt_PVNV)
3721 sv_upgrade(sv, SVt_NV);
3723 (void)SvNOK_only(sv);
3727 while (isALPHA(*d)) d++;
3728 while (isDIGIT(*d)) d++;
3730 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
3734 while (d >= SvPVX(sv)) {
3742 /* MKS: The original code here died if letters weren't consecutive.
3743 * at least it didn't have to worry about non-C locales. The
3744 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3745 * arranged in order (although not consecutively) and that only
3746 * [A-Za-z] are accepted by isALPHA in the C locale.
3748 if (*d != 'z' && *d != 'Z') {
3749 do { ++*d; } while (!isALPHA(*d));
3752 *(d--) -= 'z' - 'a';
3757 *(d--) -= 'z' - 'a' + 1;
3761 /* oh,oh, the number grew */
3762 SvGROW(sv, SvCUR(sv) + 2);
3764 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3773 Perl_sv_dec(pTHX_ register SV *sv)
3781 if (SvTHINKFIRST(sv)) {
3782 if (SvREADONLY(sv)) {
3784 if (PL_curcop != &PL_compiling)
3785 Perl_croak(aTHX_ PL_no_modify);
3789 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3796 flags = SvFLAGS(sv);
3797 if (flags & SVp_NOK) {
3799 (void)SvNOK_only(sv);
3802 if (flags & SVp_IOK) {
3804 if (SvUVX(sv) == 0) {
3805 (void)SvIOK_only(sv);
3809 (void)SvIOK_only_UV(sv);
3813 if (SvIVX(sv) == IV_MIN)
3814 sv_setnv(sv, (NV)IV_MIN - 1.0);
3816 (void)SvIOK_only(sv);
3822 if (!(flags & SVp_POK)) {
3823 if ((flags & SVTYPEMASK) < SVt_PVNV)
3824 sv_upgrade(sv, SVt_NV);
3826 (void)SvNOK_only(sv);
3829 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
3832 /* Make a string that will exist for the duration of the expression
3833 * evaluation. Actually, it may have to last longer than that, but
3834 * hopefully we won't free it until it has been assigned to a
3835 * permanent location. */
3838 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3844 sv_setsv(sv,oldstr);
3846 PL_tmps_stack[++PL_tmps_ix] = sv;
3852 Perl_sv_newmortal(pTHX)
3858 SvFLAGS(sv) = SVs_TEMP;
3860 PL_tmps_stack[++PL_tmps_ix] = sv;
3864 /* same thing without the copying */
3867 Perl_sv_2mortal(pTHX_ register SV *sv)
3872 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3875 PL_tmps_stack[++PL_tmps_ix] = sv;
3881 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3888 sv_setpvn(sv,s,len);
3893 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3898 sv_setpvn(sv,s,len);
3902 #if defined(PERL_IMPLICIT_CONTEXT)
3904 Perl_newSVpvf_nocontext(const char* pat, ...)
3909 va_start(args, pat);
3910 sv = vnewSVpvf(pat, &args);
3917 Perl_newSVpvf(pTHX_ const char* pat, ...)
3921 va_start(args, pat);
3922 sv = vnewSVpvf(pat, &args);
3928 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
3932 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
3937 Perl_newSVnv(pTHX_ NV n)
3947 Perl_newSViv(pTHX_ IV i)
3957 Perl_newRV_noinc(pTHX_ SV *tmpRef)
3963 sv_upgrade(sv, SVt_RV);
3971 Perl_newRV(pTHX_ SV *tmpRef)
3973 return newRV_noinc(SvREFCNT_inc(tmpRef));
3976 /* make an exact duplicate of old */
3979 Perl_newSVsv(pTHX_ register SV *old)
3986 if (SvTYPE(old) == SVTYPEMASK) {
3987 if (ckWARN_d(WARN_INTERNAL))
3988 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4003 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4011 char todo[PERL_UCHAR_MAX+1];
4016 if (!*s) { /* reset ?? searches */
4017 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4018 pm->op_pmdynflags &= ~PMdf_USED;
4023 /* reset variables */
4025 if (!HvARRAY(stash))
4028 Zero(todo, 256, char);
4030 i = (unsigned char)*s;
4034 max = (unsigned char)*s++;
4035 for ( ; i <= max; i++) {
4038 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4039 for (entry = HvARRAY(stash)[i];
4041 entry = HeNEXT(entry))
4043 if (!todo[(U8)*HeKEY(entry)])
4045 gv = (GV*)HeVAL(entry);
4047 if (SvTHINKFIRST(sv)) {
4048 if (!SvREADONLY(sv) && SvROK(sv))
4053 if (SvTYPE(sv) >= SVt_PV) {
4055 if (SvPVX(sv) != Nullch)
4062 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4064 #ifndef VMS /* VMS has no environ array */
4066 environ[0] = Nullch;
4075 Perl_sv_2io(pTHX_ SV *sv)
4081 switch (SvTYPE(sv)) {
4089 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4093 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4095 return sv_2io(SvRV(sv));
4096 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4102 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4109 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4116 return *gvp = Nullgv, Nullcv;
4117 switch (SvTYPE(sv)) {
4137 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4138 tryAMAGICunDEREF(to_cv);
4141 if (SvTYPE(sv) == SVt_PVCV) {
4150 Perl_croak(aTHX_ "Not a subroutine reference");
4155 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4161 if (lref && !GvCVu(gv)) {
4164 tmpsv = NEWSV(704,0);
4165 gv_efullname3(tmpsv, gv, Nullch);
4166 /* XXX this is probably not what they think they're getting.
4167 * It has the same effect as "sub name;", i.e. just a forward
4169 newSUB(start_subparse(FALSE, 0),
4170 newSVOP(OP_CONST, 0, tmpsv),
4175 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4182 Perl_sv_true(pTHX_ register SV *sv)
4189 if ((tXpv = (XPV*)SvANY(sv)) &&
4190 (*tXpv->xpv_pv > '0' ||
4191 tXpv->xpv_cur > 1 ||
4192 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4199 return SvIVX(sv) != 0;
4202 return SvNVX(sv) != 0.0;
4204 return sv_2bool(sv);
4210 Perl_sv_iv(pTHX_ register SV *sv)
4214 return (IV)SvUVX(sv);
4221 Perl_sv_uv(pTHX_ register SV *sv)
4226 return (UV)SvIVX(sv);
4232 Perl_sv_nv(pTHX_ register SV *sv)
4240 Perl_sv_pv(pTHX_ SV *sv)
4247 return sv_2pv(sv, &n_a);
4251 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4257 return sv_2pv(sv, lp);
4261 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4265 if (SvTHINKFIRST(sv) && !SvROK(sv))
4266 sv_force_normal(sv);
4272 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4274 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4275 PL_op_name[PL_op->op_type]);
4279 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4284 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4285 SvGROW(sv, len + 1);
4286 Move(s,SvPVX(sv),len,char);
4291 SvPOK_on(sv); /* validate pointer */
4293 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4294 (unsigned long)sv,SvPVX(sv)));
4301 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4303 if (ob && SvOBJECT(sv))
4304 return HvNAME(SvSTASH(sv));
4306 switch (SvTYPE(sv)) {
4320 case SVt_PVLV: return "LVALUE";
4321 case SVt_PVAV: return "ARRAY";
4322 case SVt_PVHV: return "HASH";
4323 case SVt_PVCV: return "CODE";
4324 case SVt_PVGV: return "GLOB";
4325 case SVt_PVFM: return "FORMAT";
4326 default: return "UNKNOWN";
4332 Perl_sv_isobject(pTHX_ SV *sv)
4347 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4359 return strEQ(HvNAME(SvSTASH(sv)), name);
4363 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4370 SV_CHECK_THINKFIRST(rv);
4373 if (SvTYPE(rv) < SVt_RV)
4374 sv_upgrade(rv, SVt_RV);
4381 HV* stash = gv_stashpv(classname, TRUE);
4382 (void)sv_bless(rv, stash);
4388 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4391 sv_setsv(rv, &PL_sv_undef);
4395 sv_setiv(newSVrv(rv,classname), (IV)pv);
4400 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4402 sv_setiv(newSVrv(rv,classname), iv);
4407 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4409 sv_setnv(newSVrv(rv,classname), nv);
4414 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4416 sv_setpvn(newSVrv(rv,classname), pv, n);
4421 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4426 Perl_croak(aTHX_ "Can't bless non-reference value");
4428 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4429 if (SvREADONLY(tmpRef))
4430 Perl_croak(aTHX_ PL_no_modify);
4431 if (SvOBJECT(tmpRef)) {
4432 if (SvTYPE(tmpRef) != SVt_PVIO)
4434 SvREFCNT_dec(SvSTASH(tmpRef));
4437 SvOBJECT_on(tmpRef);
4438 if (SvTYPE(tmpRef) != SVt_PVIO)
4440 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4441 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4452 S_sv_unglob(pTHX_ SV *sv)
4454 assert(SvTYPE(sv) == SVt_PVGV);
4459 SvREFCNT_dec(GvSTASH(sv));
4460 GvSTASH(sv) = Nullhv;
4462 sv_unmagic(sv, '*');
4463 Safefree(GvNAME(sv));
4465 SvFLAGS(sv) &= ~SVTYPEMASK;
4466 SvFLAGS(sv) |= SVt_PVMG;
4470 Perl_sv_unref(pTHX_ SV *sv)
4474 if (SvWEAKREF(sv)) {
4482 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4485 sv_2mortal(rv); /* Schedule for freeing later */
4489 Perl_sv_taint(pTHX_ SV *sv)
4491 sv_magic((sv), Nullsv, 't', Nullch, 0);
4495 Perl_sv_untaint(pTHX_ SV *sv)
4497 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4498 MAGIC *mg = mg_find(sv, 't');
4505 Perl_sv_tainted(pTHX_ SV *sv)
4507 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4508 MAGIC *mg = mg_find(sv, 't');
4509 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4516 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4518 char buf[TYPE_CHARS(UV)];
4520 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4522 sv_setpvn(sv, ptr, ebuf - ptr);
4527 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4529 char buf[TYPE_CHARS(UV)];
4531 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4533 sv_setpvn(sv, ptr, ebuf - ptr);
4537 #if defined(PERL_IMPLICIT_CONTEXT)
4539 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4543 va_start(args, pat);
4544 sv_vsetpvf(sv, pat, &args);
4550 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4554 va_start(args, pat);
4555 sv_vsetpvf_mg(sv, pat, &args);
4561 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4564 va_start(args, pat);
4565 sv_vsetpvf(sv, pat, &args);
4570 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4572 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4576 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4579 va_start(args, pat);
4580 sv_vsetpvf_mg(sv, pat, &args);
4585 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4587 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4591 #if defined(PERL_IMPLICIT_CONTEXT)
4593 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4597 va_start(args, pat);
4598 sv_vcatpvf(sv, pat, &args);
4603 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4607 va_start(args, pat);
4608 sv_vcatpvf_mg(sv, pat, &args);
4614 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4617 va_start(args, pat);
4618 sv_vcatpvf(sv, pat, &args);
4623 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4625 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4629 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4632 va_start(args, pat);
4633 sv_vcatpvf_mg(sv, pat, &args);
4638 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4640 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4645 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4647 sv_setpvn(sv, "", 0);
4648 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4652 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4660 static char nullstr[] = "(null)";
4662 /* no matter what, this is a string now */
4663 (void)SvPV_force(sv, origlen);
4665 /* special-case "", "%s", and "%_" */
4668 if (patlen == 2 && pat[0] == '%') {
4672 char *s = va_arg(*args, char*);
4673 sv_catpv(sv, s ? s : nullstr);
4675 else if (svix < svmax)
4676 sv_catsv(sv, *svargs);
4680 sv_catsv(sv, va_arg(*args, SV*));
4683 /* See comment on '_' below */
4688 patend = (char*)pat + patlen;
4689 for (p = (char*)pat; p < patend; p = q) {
4697 bool has_precis = FALSE;
4702 STRLEN esignlen = 0;
4704 char *eptr = Nullch;
4706 /* Times 4: a decimal digit takes more than 3 binary digits.
4707 * NV_DIG: mantissa takes than many decimal digits.
4708 * Plus 32: Playing safe. */
4709 char ebuf[IV_DIG * 4 + NV_DIG + 32];
4710 /* large enough for "%#.#f" --chip */
4711 /* what about long double NVs? --jhi */
4722 for (q = p; q < patend && *q != '%'; ++q) ;
4724 sv_catpvn(sv, p, q - p);
4762 case '1': case '2': case '3':
4763 case '4': case '5': case '6':
4764 case '7': case '8': case '9':
4767 width = width * 10 + (*q++ - '0');
4772 i = va_arg(*args, int);
4774 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4776 width = (i < 0) ? -i : i;
4787 i = va_arg(*args, int);
4789 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4790 precis = (i < 0) ? 0 : i;
4796 precis = precis * 10 + (*q++ - '0');
4806 if (*(q + 1) == 'l') { /* lld */
4838 uv = va_arg(*args, int);
4840 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4842 eptr = (char*)utf8buf;
4843 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4847 c = va_arg(*args, int);
4849 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4856 eptr = va_arg(*args, char*);
4858 elen = strlen(eptr);
4861 elen = sizeof nullstr - 1;
4864 else if (svix < svmax) {
4865 eptr = SvPVx(svargs[svix++], elen);
4867 if (has_precis && precis < elen) {
4869 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4872 if (width) { /* fudge width (can't fudge elen) */
4873 width += elen - sv_len_utf8(svargs[svix - 1]);
4881 * The "%_" hack might have to be changed someday,
4882 * if ISO or ANSI decide to use '_' for something.
4883 * So we keep it hidden from users' code.
4887 eptr = SvPVx(va_arg(*args, SV*), elen);
4890 if (has_precis && elen > precis)
4898 uv = (UV)va_arg(*args, void*);
4900 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4915 case 'h': iv = (short)va_arg(*args, int); break;
4917 default: iv = va_arg(*args, IV); break;
4919 default: iv = va_arg(*args, int); break;
4921 case 'l': iv = va_arg(*args, long); break;
4922 case 'V': iv = va_arg(*args, IV); break;
4924 case 'q': iv = va_arg(*args, Quad_t); break;
4929 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4931 case 'h': iv = (short)iv; break;
4935 default: iv = (int)iv; break;
4937 case 'l': iv = (long)iv; break;
4940 case 'q': iv = (Quad_t)iv; break;
4947 esignbuf[esignlen++] = plus;
4951 esignbuf[esignlen++] = '-';
4989 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4991 default: uv = va_arg(*args, UV); break;
4993 default: uv = va_arg(*args, unsigned); break;
4995 case 'l': uv = va_arg(*args, unsigned long); break;
4996 case 'V': uv = va_arg(*args, UV); break;
4998 case 'q': uv = va_arg(*args, Quad_t); break;
5003 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5005 case 'h': uv = (unsigned short)uv; break;
5009 default: uv = (unsigned)uv; break;
5011 case 'l': uv = (unsigned long)uv; break;
5014 case 'q': uv = (Quad_t)uv; break;
5020 eptr = ebuf + sizeof ebuf;
5026 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5032 esignbuf[esignlen++] = '0';
5033 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5039 *--eptr = '0' + dig;
5041 if (alt && *eptr != '0')
5047 *--eptr = '0' + dig;
5049 if (alt && *eptr != '0')
5052 default: /* it had better be ten or less */
5055 *--eptr = '0' + dig;
5056 } while (uv /= base);
5059 elen = (ebuf + sizeof ebuf) - eptr;
5062 zeros = precis - elen;
5063 else if (precis == 0 && elen == 1 && *eptr == '0')
5068 /* FLOATING POINT */
5071 c = 'f'; /* maybe %F isn't supported here */
5077 /* This is evil, but floating point is even more evil */
5080 nv = va_arg(*args, NV);
5082 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5085 if (c != 'e' && c != 'E') {
5087 (void)frexp(nv, &i);
5088 if (i == PERL_INT_MIN)
5089 Perl_die(aTHX_ "panic: frexp");
5091 need = BIT_DIGITS(i);
5093 need += has_precis ? precis : 6; /* known default */
5097 need += 20; /* fudge factor */
5098 if (PL_efloatsize < need) {
5099 Safefree(PL_efloatbuf);
5100 PL_efloatsize = need + 20; /* more fudge */
5101 New(906, PL_efloatbuf, PL_efloatsize, char);
5104 eptr = ebuf + sizeof ebuf;
5107 #ifdef USE_LONG_DOUBLE
5109 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5110 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5115 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5120 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5133 RESTORE_NUMERIC_STANDARD();
5134 (void)sprintf(PL_efloatbuf, eptr, nv);
5135 RESTORE_NUMERIC_LOCAL();
5138 eptr = PL_efloatbuf;
5139 elen = strlen(PL_efloatbuf);
5143 * User-defined locales may include arbitrary characters.
5144 * And, unfortunately, some system may alloc the "C" locale
5145 * to be overridden by a malicious user.
5148 *used_locale = TRUE;
5149 #endif /* LC_NUMERIC */
5156 i = SvCUR(sv) - origlen;
5159 case 'h': *(va_arg(*args, short*)) = i; break;
5161 default: *(va_arg(*args, IV*)) = i; break;
5163 default: *(va_arg(*args, int*)) = i; break;
5165 case 'l': *(va_arg(*args, long*)) = i; break;
5166 case 'V': *(va_arg(*args, IV*)) = i; break;
5168 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5172 else if (svix < svmax)
5173 sv_setuv(svargs[svix++], (UV)i);
5174 continue; /* not "break" */
5180 if (!args && ckWARN(WARN_PRINTF) &&
5181 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5182 SV *msg = sv_newmortal();
5183 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5184 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5188 Perl_sv_catpvf(aTHX_ msg,
5189 "\"%%%c\"", c & 0xFF);
5191 Perl_sv_catpvf(aTHX_ msg,
5192 "\"%%\\%03" PERL_PRIo64 "\"",
5195 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ?
5196 "\"%%%c\"" : "\"%%\\%03o\"",
5200 sv_catpv(msg, "end of string");
5201 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5204 /* output mangled stuff ... */
5210 /* ... right here, because formatting flags should not apply */
5211 SvGROW(sv, SvCUR(sv) + elen + 1);
5213 memcpy(p, eptr, elen);
5216 SvCUR(sv) = p - SvPVX(sv);
5217 continue; /* not "break" */
5220 have = esignlen + zeros + elen;
5221 need = (have > width ? have : width);
5224 SvGROW(sv, SvCUR(sv) + need + 1);
5226 if (esignlen && fill == '0') {
5227 for (i = 0; i < esignlen; i++)
5231 memset(p, fill, gap);
5234 if (esignlen && fill != '0') {
5235 for (i = 0; i < esignlen; i++)
5239 for (i = zeros; i; i--)
5243 memcpy(p, eptr, elen);
5247 memset(p, ' ', gap);
5251 SvCUR(sv) = p - SvPVX(sv);
5262 do_report_used(pTHXo_ SV *sv)
5264 if (SvTYPE(sv) != SVTYPEMASK) {
5265 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
5266 PerlIO_printf(PerlIO_stderr(), "****\n");
5272 do_clean_objs(pTHXo_ SV *sv)
5276 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5277 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
5283 /* XXX Might want to check arrays, etc. */
5286 #ifndef DISABLE_DESTRUCTOR_KLUDGE
5288 do_clean_named_objs(pTHXo_ SV *sv)
5290 if (SvTYPE(sv) == SVt_PVGV) {
5291 if ( SvOBJECT(GvSV(sv)) ||
5292 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
5293 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
5294 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
5295 GvCV(sv) && SvOBJECT(GvCV(sv)) )
5297 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
5305 do_clean_all(pTHXo_ SV *sv)
5307 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
5308 SvFLAGS(sv) |= SVf_BREAK;