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);
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,
1038 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1039 PL_op_desc[PL_op->op_type]);
1041 Perl_warner(aTHX_ WARN_NUMERIC,
1042 "Argument \"%s\" isn't numeric", tmpbuf);
1045 /* the number can be converted to integer with atol() or atoll() */
1046 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1047 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1048 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1049 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1051 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1052 until proven guilty, assume that things are not that bad... */
1055 Perl_sv_2iv(pTHX_ register SV *sv)
1059 if (SvGMAGICAL(sv)) {
1064 return I_V(SvNVX(sv));
1066 if (SvPOKp(sv) && SvLEN(sv))
1069 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1071 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1072 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1077 if (SvTHINKFIRST(sv)) {
1080 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1081 return SvIV(tmpstr);
1082 return PTR2IV(SvRV(sv));
1084 if (SvREADONLY(sv) && !SvOK(sv)) {
1086 if (ckWARN(WARN_UNINITIALIZED))
1087 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1093 return (IV)(SvUVX(sv));
1100 /* We can cache the IV/UV value even if it not good enough
1101 * to reconstruct NV, since the conversion to PV will prefer
1105 if (SvTYPE(sv) == SVt_NV)
1106 sv_upgrade(sv, SVt_PVNV);
1109 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1110 SvIVX(sv) = I_V(SvNVX(sv));
1112 SvUVX(sv) = U_V(SvNVX(sv));
1116 DEBUG_c(PerlIO_printf(Perl_debug_log,
1117 "0x%" PERL_PRIx64 " 2iv(%" PERL_PRIu64 " => %" PERL_PRId64 ") (as unsigned)\n",
1119 (UV)SvUVX(sv), (IV)SvUVX(sv)));
1121 DEBUG_c(PerlIO_printf(Perl_debug_log,
1122 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1124 (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
1126 return (IV)SvUVX(sv);
1129 else if (SvPOKp(sv) && SvLEN(sv)) {
1130 I32 numtype = looks_like_number(sv);
1132 /* We want to avoid a possible problem when we cache an IV which
1133 may be later translated to an NV, and the resulting NV is not
1134 the translation of the initial data.
1136 This means that if we cache such an IV, we need to cache the
1137 NV as well. Moreover, we trade speed for space, and do not
1138 cache the NV if not needed.
1140 if (numtype & IS_NUMBER_NOT_IV) {
1141 /* May be not an integer. Need to cache NV if we cache IV
1142 * - otherwise future conversion to NV will be wrong. */
1145 d = Atof(SvPVX(sv));
1147 if (SvTYPE(sv) < SVt_PVNV)
1148 sv_upgrade(sv, SVt_PVNV);
1152 #if defined(USE_LONG_DOUBLE)
1153 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1154 (unsigned long)sv, SvNVX(sv)));
1156 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1157 (unsigned long)sv, SvNVX(sv)));
1159 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1160 SvIVX(sv) = I_V(SvNVX(sv));
1162 SvUVX(sv) = U_V(SvNVX(sv));
1168 /* The NV may be reconstructed from IV - safe to cache IV,
1169 which may be calculated by atol(). */
1170 if (SvTYPE(sv) == SVt_PV)
1171 sv_upgrade(sv, SVt_PVIV);
1173 SvIVX(sv) = Atol(SvPVX(sv));
1175 else { /* Not a number. Cache 0. */
1178 if (SvTYPE(sv) < SVt_PVIV)
1179 sv_upgrade(sv, SVt_PVIV);
1182 if (ckWARN(WARN_NUMERIC))
1188 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1189 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1190 if (SvTYPE(sv) < SVt_IV)
1191 /* Typically the caller expects that sv_any is not NULL now. */
1192 sv_upgrade(sv, SVt_IV);
1195 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1196 (unsigned long)sv,(long)SvIVX(sv)));
1197 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1201 Perl_sv_2uv(pTHX_ register SV *sv)
1205 if (SvGMAGICAL(sv)) {
1210 return U_V(SvNVX(sv));
1211 if (SvPOKp(sv) && SvLEN(sv))
1214 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1216 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1217 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1222 if (SvTHINKFIRST(sv)) {
1225 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1226 return SvUV(tmpstr);
1227 return PTR2UV(SvRV(sv));
1229 if (SvREADONLY(sv) && !SvOK(sv)) {
1231 if (ckWARN(WARN_UNINITIALIZED))
1232 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1241 return (UV)SvIVX(sv);
1245 /* We can cache the IV/UV value even if it not good enough
1246 * to reconstruct NV, since the conversion to PV will prefer
1249 if (SvTYPE(sv) == SVt_NV)
1250 sv_upgrade(sv, SVt_PVNV);
1252 if (SvNVX(sv) >= -0.5) {
1254 SvUVX(sv) = U_V(SvNVX(sv));
1257 SvIVX(sv) = I_V(SvNVX(sv));
1260 DEBUG_c(PerlIO_printf(Perl_debug_log,
1261 "0x%" PERL_PRIx64 " 2uv(%" PERL_PRId64 " => %" PERL_PRIu64 ") (as signed)\n",
1262 (unsigned long)sv,(long)SvIVX(sv),
1263 (long)(UV)SvIVX(sv)));
1265 DEBUG_c(PerlIO_printf(Perl_debug_log,
1266 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1267 (unsigned long)sv,(long)SvIVX(sv),
1268 (long)(UV)SvIVX(sv)));
1270 return (UV)SvIVX(sv);
1273 else if (SvPOKp(sv) && SvLEN(sv)) {
1274 I32 numtype = looks_like_number(sv);
1276 /* We want to avoid a possible problem when we cache a UV which
1277 may be later translated to an NV, and the resulting NV is not
1278 the translation of the initial data.
1280 This means that if we cache such a UV, we need to cache the
1281 NV as well. Moreover, we trade speed for space, and do not
1282 cache the NV if not needed.
1284 if (numtype & IS_NUMBER_NOT_IV) {
1285 /* May be not an integer. Need to cache NV if we cache IV
1286 * - otherwise future conversion to NV will be wrong. */
1289 d = Atof(SvPVX(sv));
1291 if (SvTYPE(sv) < SVt_PVNV)
1292 sv_upgrade(sv, SVt_PVNV);
1296 #if defined(USE_LONG_DOUBLE)
1297 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1298 (unsigned long)sv, SvNVX(sv)));
1300 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1301 (unsigned long)sv, SvNVX(sv)));
1303 if (SvNVX(sv) < -0.5) {
1304 SvIVX(sv) = I_V(SvNVX(sv));
1307 SvUVX(sv) = U_V(SvNVX(sv));
1311 else if (numtype & IS_NUMBER_NEG) {
1312 /* The NV may be reconstructed from IV - safe to cache IV,
1313 which may be calculated by atol(). */
1314 if (SvTYPE(sv) == SVt_PV)
1315 sv_upgrade(sv, SVt_PVIV);
1317 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1319 else if (numtype) { /* Non-negative */
1320 /* The NV may be reconstructed from UV - safe to cache UV,
1321 which may be calculated by strtoul()/atol. */
1322 if (SvTYPE(sv) == SVt_PV)
1323 sv_upgrade(sv, SVt_PVIV);
1325 (void)SvIsUV_on(sv);
1327 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1328 #else /* no atou(), but we know the number fits into IV... */
1329 /* The only problem may be if it is negative... */
1330 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1333 else { /* Not a number. Cache 0. */
1336 if (SvTYPE(sv) < SVt_PVIV)
1337 sv_upgrade(sv, SVt_PVIV);
1338 SvUVX(sv) = 0; /* We assume that 0s have the
1339 same bitmap in IV and UV. */
1341 (void)SvIsUV_on(sv);
1342 if (ckWARN(WARN_NUMERIC))
1347 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1349 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1350 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1352 if (SvTYPE(sv) < SVt_IV)
1353 /* Typically the caller expects that sv_any is not NULL now. */
1354 sv_upgrade(sv, SVt_IV);
1358 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1359 (unsigned long)sv,SvUVX(sv)));
1360 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1364 Perl_sv_2nv(pTHX_ register SV *sv)
1368 if (SvGMAGICAL(sv)) {
1372 if (SvPOKp(sv) && SvLEN(sv)) {
1374 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1376 return Atof(SvPVX(sv));
1380 return (NV)SvUVX(sv);
1382 return (NV)SvIVX(sv);
1385 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1387 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1388 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1393 if (SvTHINKFIRST(sv)) {
1396 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1397 return SvNV(tmpstr);
1398 return PTR2NV(SvRV(sv));
1400 if (SvREADONLY(sv) && !SvOK(sv)) {
1402 if (ckWARN(WARN_UNINITIALIZED))
1403 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1407 if (SvTYPE(sv) < SVt_NV) {
1408 if (SvTYPE(sv) == SVt_IV)
1409 sv_upgrade(sv, SVt_PVNV);
1411 sv_upgrade(sv, SVt_NV);
1412 #if defined(USE_LONG_DOUBLE)
1414 RESTORE_NUMERIC_STANDARD();
1415 PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIgldbl ")\n",
1416 (unsigned long)sv, SvNVX(sv));
1417 RESTORE_NUMERIC_LOCAL();
1421 RESTORE_NUMERIC_STANDARD();
1422 PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
1423 (unsigned long)sv, SvNVX(sv));
1424 RESTORE_NUMERIC_LOCAL();
1428 else if (SvTYPE(sv) < SVt_PVNV)
1429 sv_upgrade(sv, SVt_PVNV);
1431 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1433 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1435 else if (SvPOKp(sv) && SvLEN(sv)) {
1437 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1439 SvNVX(sv) = Atof(SvPVX(sv));
1443 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1444 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1445 if (SvTYPE(sv) < SVt_NV)
1446 /* Typically the caller expects that sv_any is not NULL now. */
1447 sv_upgrade(sv, SVt_NV);
1451 #if defined(USE_LONG_DOUBLE)
1453 RESTORE_NUMERIC_STANDARD();
1454 PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1455 (unsigned long)sv, SvNVX(sv));
1456 RESTORE_NUMERIC_LOCAL();
1460 RESTORE_NUMERIC_STANDARD();
1461 PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
1462 (unsigned long)sv, SvNVX(sv));
1463 RESTORE_NUMERIC_LOCAL();
1470 S_asIV(pTHX_ SV *sv)
1472 I32 numtype = looks_like_number(sv);
1475 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1476 return Atol(SvPVX(sv));
1479 if (ckWARN(WARN_NUMERIC))
1482 d = Atof(SvPVX(sv));
1487 S_asUV(pTHX_ SV *sv)
1489 I32 numtype = looks_like_number(sv);
1492 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1493 return Strtoul(SvPVX(sv), Null(char**), 10);
1497 if (ckWARN(WARN_NUMERIC))
1500 return U_V(Atof(SvPVX(sv)));
1504 * Returns a combination of (advisory only - can get false negatives)
1505 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1507 * 0 if does not look like number.
1509 * In fact possible values are 0 and
1510 * IS_NUMBER_TO_INT_BY_ATOL 123
1511 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1512 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1513 * with a possible addition of IS_NUMBER_NEG.
1517 Perl_looks_like_number(pTHX_ SV *sv)
1520 register char *send;
1521 register char *sbegin;
1522 register char *nbegin;
1530 else if (SvPOKp(sv))
1531 sbegin = SvPV(sv, len);
1534 send = sbegin + len;
1541 numtype = IS_NUMBER_NEG;
1548 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1549 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1553 /* next must be digit or the radix separator */
1557 } while (isDIGIT(*s));
1559 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1560 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1562 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1565 #ifdef USE_LOCALE_NUMERIC
1566 || IS_NUMERIC_RADIX(*s)
1570 numtype |= IS_NUMBER_NOT_IV;
1571 while (isDIGIT(*s)) /* optional digits after the radix */
1576 #ifdef USE_LOCALE_NUMERIC
1577 || IS_NUMERIC_RADIX(*s)
1581 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1582 /* no digits before the radix means we need digits after it */
1586 } while (isDIGIT(*s));
1594 /* we can have an optional exponent part */
1595 if (*s == 'e' || *s == 'E') {
1596 numtype &= ~IS_NUMBER_NEG;
1597 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1599 if (*s == '+' || *s == '-')
1604 } while (isDIGIT(*s));
1613 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1614 return IS_NUMBER_TO_INT_BY_ATOL;
1619 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1622 return sv_2pv(sv, &n_a);
1625 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1627 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1630 char *ptr = buf + TYPE_CHARS(UV);
1645 *--ptr = '0' + (uv % 10);
1654 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1659 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1660 char *tmpbuf = tbuf;
1666 if (SvGMAGICAL(sv)) {
1675 (void)sprintf(tmpbuf,"%" PERL_PRIu64,(UV)SvUVX(sv));
1677 (void)sprintf(tmpbuf,"%" PERL_PRId64,(IV)SvIVX(sv));
1680 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1682 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1688 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
1693 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1695 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1696 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1702 if (SvTHINKFIRST(sv)) {
1705 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1706 return SvPV(tmpstr,*lp);
1713 switch (SvTYPE(sv)) {
1715 if ( ((SvFLAGS(sv) &
1716 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1717 == (SVs_OBJECT|SVs_RMG))
1718 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1719 && (mg = mg_find(sv, 'r'))) {
1721 regexp *re = (regexp *)mg->mg_obj;
1724 char *fptr = "msix";
1729 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1731 while(ch = *fptr++) {
1733 reflags[left++] = ch;
1736 reflags[right--] = ch;
1741 reflags[left] = '-';
1745 mg->mg_len = re->prelen + 4 + left;
1746 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1747 Copy("(?", mg->mg_ptr, 2, char);
1748 Copy(reflags, mg->mg_ptr+2, left, char);
1749 Copy(":", mg->mg_ptr+left+2, 1, char);
1750 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1751 mg->mg_ptr[mg->mg_len - 1] = ')';
1752 mg->mg_ptr[mg->mg_len] = 0;
1754 PL_reginterp_cnt += re->program[0].next_off;
1766 case SVt_PVBM: s = "SCALAR"; break;
1767 case SVt_PVLV: s = "LVALUE"; break;
1768 case SVt_PVAV: s = "ARRAY"; break;
1769 case SVt_PVHV: s = "HASH"; break;
1770 case SVt_PVCV: s = "CODE"; break;
1771 case SVt_PVGV: s = "GLOB"; break;
1772 case SVt_PVFM: s = "FORMAT"; break;
1773 case SVt_PVIO: s = "IO"; break;
1774 default: s = "UNKNOWN"; break;
1778 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1782 Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", PTR2UV(sv));
1784 Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
1791 if (SvREADONLY(sv) && !SvOK(sv)) {
1793 if (ckWARN(WARN_UNINITIALIZED))
1794 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1799 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1800 /* XXXX 64-bit? IV may have better precision... */
1801 /* I tried changing this for to be 64-bit-aware and
1802 * the t/op/numconvert.t became very, very, angry.
1804 if (SvTYPE(sv) < SVt_PVNV)
1805 sv_upgrade(sv, SVt_PVNV);
1808 olderrno = errno; /* some Xenix systems wipe out errno here */
1810 if (SvNVX(sv) == 0.0)
1811 (void)strcpy(s,"0");
1815 Gconvert(SvNVX(sv), NV_DIG, 0, s);
1818 #ifdef FIXNEGATIVEZERO
1819 if (*s == '-' && s[1] == '0' && !s[2])
1828 else if (SvIOKp(sv)) {
1829 U32 isIOK = SvIOK(sv);
1830 U32 isUIOK = SvIsUV(sv);
1831 char buf[TYPE_CHARS(UV)];
1834 if (SvTYPE(sv) < SVt_PVIV)
1835 sv_upgrade(sv, SVt_PVIV);
1837 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1839 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1840 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
1841 Move(ptr,SvPVX(sv),ebuf - ptr,char);
1842 SvCUR_set(sv, ebuf - ptr);
1855 if (ckWARN(WARN_UNINITIALIZED)
1856 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1858 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1861 if (SvTYPE(sv) < SVt_PV)
1862 /* Typically the caller expects that sv_any is not NULL now. */
1863 sv_upgrade(sv, SVt_PV);
1866 *lp = s - SvPVX(sv);
1869 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
1870 (unsigned long)sv,SvPVX(sv)));
1874 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1875 /* Sneaky stuff here */
1879 tsv = newSVpv(tmpbuf, 0);
1895 len = strlen(tmpbuf);
1897 #ifdef FIXNEGATIVEZERO
1898 if (len == 2 && t[0] == '-' && t[1] == '0') {
1903 (void)SvUPGRADE(sv, SVt_PV);
1905 s = SvGROW(sv, len + 1);
1913 /* This function is only called on magical items */
1915 Perl_sv_2bool(pTHX_ register SV *sv)
1925 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1926 return SvTRUE(tmpsv);
1927 return SvRV(sv) != 0;
1930 register XPV* Xpvtmp;
1931 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1932 (*Xpvtmp->xpv_pv > '0' ||
1933 Xpvtmp->xpv_cur > 1 ||
1934 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
1941 return SvIVX(sv) != 0;
1944 return SvNVX(sv) != 0.0;
1951 /* Note: sv_setsv() should not be called with a source string that needs
1952 * to be reused, since it may destroy the source string if it is marked
1957 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
1960 register U32 sflags;
1966 SV_CHECK_THINKFIRST(dstr);
1968 sstr = &PL_sv_undef;
1969 stype = SvTYPE(sstr);
1970 dtype = SvTYPE(dstr);
1974 /* There's a lot of redundancy below but we're going for speed here */
1979 if (dtype != SVt_PVGV) {
1980 (void)SvOK_off(dstr);
1988 sv_upgrade(dstr, SVt_IV);
1991 sv_upgrade(dstr, SVt_PVNV);
1995 sv_upgrade(dstr, SVt_PVIV);
1998 (void)SvIOK_only(dstr);
1999 SvIVX(dstr) = SvIVX(sstr);
2012 sv_upgrade(dstr, SVt_NV);
2017 sv_upgrade(dstr, SVt_PVNV);
2020 SvNVX(dstr) = SvNVX(sstr);
2021 (void)SvNOK_only(dstr);
2029 sv_upgrade(dstr, SVt_RV);
2030 else if (dtype == SVt_PVGV &&
2031 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2034 if (PL_curcop->cop_stash != GvSTASH(dstr))
2035 GvIMPORTED_on(dstr);
2045 sv_upgrade(dstr, SVt_PV);
2048 if (dtype < SVt_PVIV)
2049 sv_upgrade(dstr, SVt_PVIV);
2052 if (dtype < SVt_PVNV)
2053 sv_upgrade(dstr, SVt_PVNV);
2060 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2061 PL_op_name[PL_op->op_type]);
2063 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2067 if (dtype <= SVt_PVGV) {
2069 if (dtype != SVt_PVGV) {
2070 char *name = GvNAME(sstr);
2071 STRLEN len = GvNAMELEN(sstr);
2072 sv_upgrade(dstr, SVt_PVGV);
2073 sv_magic(dstr, dstr, '*', name, len);
2074 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2075 GvNAME(dstr) = savepvn(name, len);
2076 GvNAMELEN(dstr) = len;
2077 SvFAKE_on(dstr); /* can coerce to non-glob */
2079 /* ahem, death to those who redefine active sort subs */
2080 else if (PL_curstackinfo->si_type == PERLSI_SORT
2081 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2082 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2084 (void)SvOK_off(dstr);
2085 GvINTRO_off(dstr); /* one-shot flag */
2087 GvGP(dstr) = gp_ref(GvGP(sstr));
2089 if (PL_curcop->cop_stash != GvSTASH(dstr))
2090 GvIMPORTED_on(dstr);
2097 if (SvGMAGICAL(sstr)) {
2099 if (SvTYPE(sstr) != stype) {
2100 stype = SvTYPE(sstr);
2101 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2105 if (stype == SVt_PVLV)
2106 (void)SvUPGRADE(dstr, SVt_PVNV);
2108 (void)SvUPGRADE(dstr, stype);
2111 sflags = SvFLAGS(sstr);
2113 if (sflags & SVf_ROK) {
2114 if (dtype >= SVt_PV) {
2115 if (dtype == SVt_PVGV) {
2116 SV *sref = SvREFCNT_inc(SvRV(sstr));
2118 int intro = GvINTRO(dstr);
2122 GvGP(dstr)->gp_refcnt--;
2123 GvINTRO_off(dstr); /* one-shot flag */
2124 Newz(602,gp, 1, GP);
2125 GvGP(dstr) = gp_ref(gp);
2126 GvSV(dstr) = NEWSV(72,0);
2127 GvLINE(dstr) = PL_curcop->cop_line;
2128 GvEGV(dstr) = (GV*)dstr;
2131 switch (SvTYPE(sref)) {
2134 SAVESPTR(GvAV(dstr));
2136 dref = (SV*)GvAV(dstr);
2137 GvAV(dstr) = (AV*)sref;
2138 if (PL_curcop->cop_stash != GvSTASH(dstr))
2139 GvIMPORTED_AV_on(dstr);
2143 SAVESPTR(GvHV(dstr));
2145 dref = (SV*)GvHV(dstr);
2146 GvHV(dstr) = (HV*)sref;
2147 if (PL_curcop->cop_stash != GvSTASH(dstr))
2148 GvIMPORTED_HV_on(dstr);
2152 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2153 SvREFCNT_dec(GvCV(dstr));
2154 GvCV(dstr) = Nullcv;
2155 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2156 PL_sub_generation++;
2158 SAVESPTR(GvCV(dstr));
2161 dref = (SV*)GvCV(dstr);
2162 if (GvCV(dstr) != (CV*)sref) {
2163 CV* cv = GvCV(dstr);
2165 if (!GvCVGEN((GV*)dstr) &&
2166 (CvROOT(cv) || CvXSUB(cv)))
2168 SV *const_sv = cv_const_sv(cv);
2169 bool const_changed = TRUE;
2171 const_changed = sv_cmp(const_sv,
2172 op_const_sv(CvSTART((CV*)sref),
2174 /* ahem, death to those who redefine
2175 * active sort subs */
2176 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2177 PL_sortcop == CvSTART(cv))
2179 "Can't redefine active sort subroutine %s",
2180 GvENAME((GV*)dstr));
2181 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2182 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2183 && HvNAME(GvSTASH(CvGV(cv)))
2184 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2186 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2187 "Constant subroutine %s redefined"
2188 : "Subroutine %s redefined",
2189 GvENAME((GV*)dstr));
2192 cv_ckproto(cv, (GV*)dstr,
2193 SvPOK(sref) ? SvPVX(sref) : Nullch);
2195 GvCV(dstr) = (CV*)sref;
2196 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2197 GvASSUMECV_on(dstr);
2198 PL_sub_generation++;
2200 if (PL_curcop->cop_stash != GvSTASH(dstr))
2201 GvIMPORTED_CV_on(dstr);
2205 SAVESPTR(GvIOp(dstr));
2207 dref = (SV*)GvIOp(dstr);
2208 GvIOp(dstr) = (IO*)sref;
2212 SAVESPTR(GvSV(dstr));
2214 dref = (SV*)GvSV(dstr);
2216 if (PL_curcop->cop_stash != GvSTASH(dstr))
2217 GvIMPORTED_SV_on(dstr);
2228 (void)SvOOK_off(dstr); /* backoff */
2230 Safefree(SvPVX(dstr));
2231 SvLEN(dstr)=SvCUR(dstr)=0;
2234 (void)SvOK_off(dstr);
2235 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2237 if (sflags & SVp_NOK) {
2239 SvNVX(dstr) = SvNVX(sstr);
2241 if (sflags & SVp_IOK) {
2242 (void)SvIOK_on(dstr);
2243 SvIVX(dstr) = SvIVX(sstr);
2247 if (SvAMAGIC(sstr)) {
2251 else if (sflags & SVp_POK) {
2254 * Check to see if we can just swipe the string. If so, it's a
2255 * possible small lose on short strings, but a big win on long ones.
2256 * It might even be a win on short strings if SvPVX(dstr)
2257 * has to be allocated and SvPVX(sstr) has to be freed.
2260 if (SvTEMP(sstr) && /* slated for free anyway? */
2261 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2262 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2264 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2266 SvFLAGS(dstr) &= ~SVf_OOK;
2267 Safefree(SvPVX(dstr) - SvIVX(dstr));
2269 else if (SvLEN(dstr))
2270 Safefree(SvPVX(dstr));
2272 (void)SvPOK_only(dstr);
2273 SvPV_set(dstr, SvPVX(sstr));
2274 SvLEN_set(dstr, SvLEN(sstr));
2275 SvCUR_set(dstr, SvCUR(sstr));
2277 (void)SvOK_off(sstr);
2278 SvPV_set(sstr, Nullch);
2283 else { /* have to copy actual string */
2284 STRLEN len = SvCUR(sstr);
2286 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2287 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2288 SvCUR_set(dstr, len);
2289 *SvEND(dstr) = '\0';
2290 (void)SvPOK_only(dstr);
2293 if (sflags & SVp_NOK) {
2295 SvNVX(dstr) = SvNVX(sstr);
2297 if (sflags & SVp_IOK) {
2298 (void)SvIOK_on(dstr);
2299 SvIVX(dstr) = SvIVX(sstr);
2304 else if (sflags & SVp_NOK) {
2305 SvNVX(dstr) = SvNVX(sstr);
2306 (void)SvNOK_only(dstr);
2308 (void)SvIOK_on(dstr);
2309 SvIVX(dstr) = SvIVX(sstr);
2310 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2315 else if (sflags & SVp_IOK) {
2316 (void)SvIOK_only(dstr);
2317 SvIVX(dstr) = SvIVX(sstr);
2322 if (dtype == SVt_PVGV) {
2323 if (ckWARN(WARN_UNSAFE))
2324 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2327 (void)SvOK_off(dstr);
2333 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2335 sv_setsv(dstr,sstr);
2340 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2342 register char *dptr;
2343 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2344 elicit a warning, but it won't hurt. */
2345 SV_CHECK_THINKFIRST(sv);
2350 (void)SvUPGRADE(sv, SVt_PV);
2352 SvGROW(sv, len + 1);
2354 Move(ptr,dptr,len,char);
2357 (void)SvPOK_only(sv); /* validate pointer */
2362 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2364 sv_setpvn(sv,ptr,len);
2369 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2371 register STRLEN len;
2373 SV_CHECK_THINKFIRST(sv);
2379 (void)SvUPGRADE(sv, SVt_PV);
2381 SvGROW(sv, len + 1);
2382 Move(ptr,SvPVX(sv),len+1,char);
2384 (void)SvPOK_only(sv); /* validate pointer */
2389 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2396 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2398 SV_CHECK_THINKFIRST(sv);
2399 (void)SvUPGRADE(sv, SVt_PV);
2404 (void)SvOOK_off(sv);
2405 if (SvPVX(sv) && SvLEN(sv))
2406 Safefree(SvPVX(sv));
2407 Renew(ptr, len+1, char);
2410 SvLEN_set(sv, len+1);
2412 (void)SvPOK_only(sv); /* validate pointer */
2417 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2419 sv_usepvn(sv,ptr,len);
2424 Perl_sv_force_normal(pTHX_ register SV *sv)
2426 if (SvREADONLY(sv)) {
2428 if (PL_curcop != &PL_compiling)
2429 Perl_croak(aTHX_ PL_no_modify);
2433 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2438 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2442 register STRLEN delta;
2444 if (!ptr || !SvPOKp(sv))
2446 SV_CHECK_THINKFIRST(sv);
2447 if (SvTYPE(sv) < SVt_PVIV)
2448 sv_upgrade(sv,SVt_PVIV);
2451 if (!SvLEN(sv)) { /* make copy of shared string */
2452 char *pvx = SvPVX(sv);
2453 STRLEN len = SvCUR(sv);
2454 SvGROW(sv, len + 1);
2455 Move(pvx,SvPVX(sv),len,char);
2459 SvFLAGS(sv) |= SVf_OOK;
2461 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2462 delta = ptr - SvPVX(sv);
2470 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2475 junk = SvPV_force(sv, tlen);
2476 SvGROW(sv, tlen + len + 1);
2479 Move(ptr,SvPVX(sv)+tlen,len,char);
2482 (void)SvPOK_only(sv); /* validate pointer */
2487 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2489 sv_catpvn(sv,ptr,len);
2494 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2500 if (s = SvPV(sstr, len))
2501 sv_catpvn(dstr,s,len);
2505 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2507 sv_catsv(dstr,sstr);
2512 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2514 register STRLEN len;
2520 junk = SvPV_force(sv, tlen);
2522 SvGROW(sv, tlen + len + 1);
2525 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2527 (void)SvPOK_only(sv); /* validate pointer */
2532 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2539 Perl_newSV(pTHX_ STRLEN len)
2545 sv_upgrade(sv, SVt_PV);
2546 SvGROW(sv, len + 1);
2551 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2554 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2558 if (SvREADONLY(sv)) {
2560 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2561 Perl_croak(aTHX_ PL_no_modify);
2563 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2564 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2571 (void)SvUPGRADE(sv, SVt_PVMG);
2573 Newz(702,mg, 1, MAGIC);
2574 mg->mg_moremagic = SvMAGIC(sv);
2577 if (!obj || obj == sv || how == '#' || how == 'r')
2581 mg->mg_obj = SvREFCNT_inc(obj);
2582 mg->mg_flags |= MGf_REFCOUNTED;
2585 mg->mg_len = namlen;
2588 mg->mg_ptr = savepvn(name, namlen);
2589 else if (namlen == HEf_SVKEY)
2590 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2594 mg->mg_virtual = &PL_vtbl_sv;
2597 mg->mg_virtual = &PL_vtbl_amagic;
2600 mg->mg_virtual = &PL_vtbl_amagicelem;
2606 mg->mg_virtual = &PL_vtbl_bm;
2609 mg->mg_virtual = &PL_vtbl_regdata;
2612 mg->mg_virtual = &PL_vtbl_regdatum;
2615 mg->mg_virtual = &PL_vtbl_env;
2618 mg->mg_virtual = &PL_vtbl_fm;
2621 mg->mg_virtual = &PL_vtbl_envelem;
2624 mg->mg_virtual = &PL_vtbl_mglob;
2627 mg->mg_virtual = &PL_vtbl_isa;
2630 mg->mg_virtual = &PL_vtbl_isaelem;
2633 mg->mg_virtual = &PL_vtbl_nkeys;
2640 mg->mg_virtual = &PL_vtbl_dbline;
2644 mg->mg_virtual = &PL_vtbl_mutex;
2646 #endif /* USE_THREADS */
2647 #ifdef USE_LOCALE_COLLATE
2649 mg->mg_virtual = &PL_vtbl_collxfrm;
2651 #endif /* USE_LOCALE_COLLATE */
2653 mg->mg_virtual = &PL_vtbl_pack;
2657 mg->mg_virtual = &PL_vtbl_packelem;
2660 mg->mg_virtual = &PL_vtbl_regexp;
2663 mg->mg_virtual = &PL_vtbl_sig;
2666 mg->mg_virtual = &PL_vtbl_sigelem;
2669 mg->mg_virtual = &PL_vtbl_taint;
2673 mg->mg_virtual = &PL_vtbl_uvar;
2676 mg->mg_virtual = &PL_vtbl_vec;
2679 mg->mg_virtual = &PL_vtbl_substr;
2682 mg->mg_virtual = &PL_vtbl_defelem;
2685 mg->mg_virtual = &PL_vtbl_glob;
2688 mg->mg_virtual = &PL_vtbl_arylen;
2691 mg->mg_virtual = &PL_vtbl_pos;
2694 mg->mg_virtual = &PL_vtbl_backref;
2696 case '~': /* Reserved for use by extensions not perl internals. */
2697 /* Useful for attaching extension internal data to perl vars. */
2698 /* Note that multiple extensions may clash if magical scalars */
2699 /* etc holding private data from one are passed to another. */
2703 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
2707 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2711 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2715 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2718 for (mg = *mgp; mg; mg = *mgp) {
2719 if (mg->mg_type == type) {
2720 MGVTBL* vtbl = mg->mg_virtual;
2721 *mgp = mg->mg_moremagic;
2722 if (vtbl && (vtbl->svt_free != NULL))
2723 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
2724 if (mg->mg_ptr && mg->mg_type != 'g')
2725 if (mg->mg_len >= 0)
2726 Safefree(mg->mg_ptr);
2727 else if (mg->mg_len == HEf_SVKEY)
2728 SvREFCNT_dec((SV*)mg->mg_ptr);
2729 if (mg->mg_flags & MGf_REFCOUNTED)
2730 SvREFCNT_dec(mg->mg_obj);
2734 mgp = &mg->mg_moremagic;
2738 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2745 Perl_sv_rvweaken(pTHX_ SV *sv)
2748 if (!SvOK(sv)) /* let undefs pass */
2751 Perl_croak(aTHX_ "Can't weaken a nonreference");
2752 else if (SvWEAKREF(sv)) {
2754 if (ckWARN(WARN_MISC))
2755 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
2759 sv_add_backref(tsv, sv);
2766 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
2770 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2771 av = (AV*)mg->mg_obj;
2774 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2775 SvREFCNT_dec(av); /* for sv_magic */
2781 S_sv_del_backref(pTHX_ SV *sv)
2788 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2789 Perl_croak(aTHX_ "panic: del_backref");
2790 av = (AV *)mg->mg_obj;
2795 svp[i] = &PL_sv_undef; /* XXX */
2802 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2806 register char *midend;
2807 register char *bigend;
2813 Perl_croak(aTHX_ "Can't modify non-existent substring");
2814 SvPV_force(bigstr, curlen);
2815 if (offset + len > curlen) {
2816 SvGROW(bigstr, offset+len+1);
2817 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2818 SvCUR_set(bigstr, offset+len);
2821 i = littlelen - len;
2822 if (i > 0) { /* string might grow */
2823 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2824 mid = big + offset + len;
2825 midend = bigend = big + SvCUR(bigstr);
2828 while (midend > mid) /* shove everything down */
2829 *--bigend = *--midend;
2830 Move(little,big+offset,littlelen,char);
2836 Move(little,SvPVX(bigstr)+offset,len,char);
2841 big = SvPVX(bigstr);
2844 bigend = big + SvCUR(bigstr);
2846 if (midend > bigend)
2847 Perl_croak(aTHX_ "panic: sv_insert");
2849 if (mid - big > bigend - midend) { /* faster to shorten from end */
2851 Move(little, mid, littlelen,char);
2854 i = bigend - midend;
2856 Move(midend, mid, i,char);
2860 SvCUR_set(bigstr, mid - big);
2863 else if (i = mid - big) { /* faster from front */
2864 midend -= littlelen;
2866 sv_chop(bigstr,midend-i);
2871 Move(little, mid, littlelen,char);
2873 else if (littlelen) {
2874 midend -= littlelen;
2875 sv_chop(bigstr,midend);
2876 Move(little,midend,littlelen,char);
2879 sv_chop(bigstr,midend);
2884 /* make sv point to what nstr did */
2887 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2890 U32 refcnt = SvREFCNT(sv);
2891 SV_CHECK_THINKFIRST(sv);
2892 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
2893 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
2894 if (SvMAGICAL(sv)) {
2898 sv_upgrade(nsv, SVt_PVMG);
2899 SvMAGIC(nsv) = SvMAGIC(sv);
2900 SvFLAGS(nsv) |= SvMAGICAL(sv);
2906 assert(!SvREFCNT(sv));
2907 StructCopy(nsv,sv,SV);
2908 SvREFCNT(sv) = refcnt;
2909 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2914 Perl_sv_clear(pTHX_ register SV *sv)
2918 assert(SvREFCNT(sv) == 0);
2922 if (PL_defstash) { /* Still have a symbol table? */
2927 Zero(&tmpref, 1, SV);
2928 sv_upgrade(&tmpref, SVt_RV);
2930 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
2931 SvREFCNT(&tmpref) = 1;
2934 stash = SvSTASH(sv);
2935 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2938 PUSHSTACKi(PERLSI_DESTROY);
2939 SvRV(&tmpref) = SvREFCNT_inc(sv);
2944 call_sv((SV*)GvCV(destructor),
2945 G_DISCARD|G_EVAL|G_KEEPERR);
2951 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
2953 del_XRV(SvANY(&tmpref));
2956 if (PL_in_clean_objs)
2957 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
2959 /* DESTROY gave object new lease on life */
2965 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
2966 SvOBJECT_off(sv); /* Curse the object. */
2967 if (SvTYPE(sv) != SVt_PVIO)
2968 --PL_sv_objcount; /* XXX Might want something more general */
2971 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2974 switch (SvTYPE(sv)) {
2977 IoIFP(sv) != PerlIO_stdin() &&
2978 IoIFP(sv) != PerlIO_stdout() &&
2979 IoIFP(sv) != PerlIO_stderr())
2981 io_close((IO*)sv, FALSE);
2984 PerlDir_close(IoDIRP(sv));
2987 Safefree(IoTOP_NAME(sv));
2988 Safefree(IoFMT_NAME(sv));
2989 Safefree(IoBOTTOM_NAME(sv));
3004 SvREFCNT_dec(LvTARG(sv));
3008 Safefree(GvNAME(sv));
3009 /* cannot decrease stash refcount yet, as we might recursively delete
3010 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3011 of stash until current sv is completely gone.
3012 -- JohnPC, 27 Mar 1998 */
3013 stash = GvSTASH(sv);
3019 (void)SvOOK_off(sv);
3027 SvREFCNT_dec(SvRV(sv));
3029 else if (SvPVX(sv) && SvLEN(sv))
3030 Safefree(SvPVX(sv));
3040 switch (SvTYPE(sv)) {
3056 del_XPVIV(SvANY(sv));
3059 del_XPVNV(SvANY(sv));
3062 del_XPVMG(SvANY(sv));
3065 del_XPVLV(SvANY(sv));
3068 del_XPVAV(SvANY(sv));
3071 del_XPVHV(SvANY(sv));
3074 del_XPVCV(SvANY(sv));
3077 del_XPVGV(SvANY(sv));
3078 /* code duplication for increased performance. */
3079 SvFLAGS(sv) &= SVf_BREAK;
3080 SvFLAGS(sv) |= SVTYPEMASK;
3081 /* decrease refcount of the stash that owns this GV, if any */
3083 SvREFCNT_dec(stash);
3084 return; /* not break, SvFLAGS reset already happened */
3086 del_XPVBM(SvANY(sv));
3089 del_XPVFM(SvANY(sv));
3092 del_XPVIO(SvANY(sv));
3095 SvFLAGS(sv) &= SVf_BREAK;
3096 SvFLAGS(sv) |= SVTYPEMASK;
3100 Perl_sv_newref(pTHX_ SV *sv)
3103 ATOMIC_INC(SvREFCNT(sv));
3108 Perl_sv_free(pTHX_ SV *sv)
3111 int refcount_is_zero;
3115 if (SvREFCNT(sv) == 0) {
3116 if (SvFLAGS(sv) & SVf_BREAK)
3118 if (PL_in_clean_all) /* All is fair */
3120 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3121 /* make sure SvREFCNT(sv)==0 happens very seldom */
3122 SvREFCNT(sv) = (~(U32)0)/2;
3125 if (ckWARN_d(WARN_INTERNAL))
3126 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3129 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3130 if (!refcount_is_zero)
3134 if (ckWARN_d(WARN_DEBUGGING))
3135 Perl_warner(aTHX_ WARN_DEBUGGING,
3136 "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3140 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3141 /* make sure SvREFCNT(sv)==0 happens very seldom */
3142 SvREFCNT(sv) = (~(U32)0)/2;
3151 Perl_sv_len(pTHX_ register SV *sv)
3160 len = mg_length(sv);
3162 junk = SvPV(sv, len);
3167 Perl_sv_len_utf8(pTHX_ register SV *sv)
3178 len = mg_length(sv);
3181 s = (U8*)SvPV(sv, len);
3192 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3197 I32 uoffset = *offsetp;
3203 start = s = (U8*)SvPV(sv, len);
3205 while (s < send && uoffset--)
3209 *offsetp = s - start;
3213 while (s < send && ulen--)
3223 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3232 s = (U8*)SvPV(sv, len);
3234 Perl_croak(aTHX_ "panic: bad byte offset");
3235 send = s + *offsetp;
3243 if (ckWARN_d(WARN_UTF8))
3244 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3252 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3264 pv1 = SvPV(str1, cur1);
3269 pv2 = SvPV(str2, cur2);
3274 return memEQ(pv1, pv2, cur1);
3278 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3281 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3283 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3287 return cur2 ? -1 : 0;
3292 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3295 return retval < 0 ? -1 : 1;
3300 return cur1 < cur2 ? -1 : 1;
3304 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3306 #ifdef USE_LOCALE_COLLATE
3312 if (PL_collation_standard)
3316 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3318 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3320 if (!pv1 || !len1) {
3331 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3334 return retval < 0 ? -1 : 1;
3337 * When the result of collation is equality, that doesn't mean
3338 * that there are no differences -- some locales exclude some
3339 * characters from consideration. So to avoid false equalities,
3340 * we use the raw string as a tiebreaker.
3346 #endif /* USE_LOCALE_COLLATE */
3348 return sv_cmp(sv1, sv2);
3351 #ifdef USE_LOCALE_COLLATE
3353 * Any scalar variable may carry an 'o' magic that contains the
3354 * scalar data of the variable transformed to such a format that
3355 * a normal memory comparison can be used to compare the data
3356 * according to the locale settings.
3359 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3363 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3364 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3369 Safefree(mg->mg_ptr);
3371 if ((xf = mem_collxfrm(s, len, &xlen))) {
3372 if (SvREADONLY(sv)) {
3375 return xf + sizeof(PL_collation_ix);
3378 sv_magic(sv, 0, 'o', 0, 0);
3379 mg = mg_find(sv, 'o');
3392 if (mg && mg->mg_ptr) {
3394 return mg->mg_ptr + sizeof(PL_collation_ix);
3402 #endif /* USE_LOCALE_COLLATE */
3405 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3410 register STDCHAR rslast;
3411 register STDCHAR *bp;
3415 SV_CHECK_THINKFIRST(sv);
3416 (void)SvUPGRADE(sv, SVt_PV);
3420 if (RsSNARF(PL_rs)) {
3424 else if (RsRECORD(PL_rs)) {
3425 I32 recsize, bytesread;
3428 /* Grab the size of the record we're getting */
3429 recsize = SvIV(SvRV(PL_rs));
3430 (void)SvPOK_only(sv); /* Validate pointer */
3431 buffer = SvGROW(sv, recsize + 1);
3434 /* VMS wants read instead of fread, because fread doesn't respect */
3435 /* RMS record boundaries. This is not necessarily a good thing to be */
3436 /* doing, but we've got no other real choice */
3437 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3439 bytesread = PerlIO_read(fp, buffer, recsize);
3441 SvCUR_set(sv, bytesread);
3442 buffer[bytesread] = '\0';
3443 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3445 else if (RsPARA(PL_rs)) {
3450 rsptr = SvPV(PL_rs, rslen);
3451 rslast = rslen ? rsptr[rslen - 1] : '\0';
3453 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3454 do { /* to make sure file boundaries work right */
3457 i = PerlIO_getc(fp);
3461 PerlIO_ungetc(fp,i);
3467 /* See if we know enough about I/O mechanism to cheat it ! */
3469 /* This used to be #ifdef test - it is made run-time test for ease
3470 of abstracting out stdio interface. One call should be cheap
3471 enough here - and may even be a macro allowing compile
3475 if (PerlIO_fast_gets(fp)) {
3478 * We're going to steal some values from the stdio struct
3479 * and put EVERYTHING in the innermost loop into registers.
3481 register STDCHAR *ptr;
3485 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3486 /* An ungetc()d char is handled separately from the regular
3487 * buffer, so we getc() it back out and stuff it in the buffer.
3489 i = PerlIO_getc(fp);
3490 if (i == EOF) return 0;
3491 *(--((*fp)->_ptr)) = (unsigned char) i;
3495 /* Here is some breathtakingly efficient cheating */
3497 cnt = PerlIO_get_cnt(fp); /* get count into register */
3498 (void)SvPOK_only(sv); /* validate pointer */
3499 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3500 if (cnt > 80 && SvLEN(sv) > append) {
3501 shortbuffered = cnt - SvLEN(sv) + append + 1;
3502 cnt -= shortbuffered;
3506 /* remember that cnt can be negative */
3507 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3512 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3513 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3514 DEBUG_P(PerlIO_printf(Perl_debug_log,
3515 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3516 DEBUG_P(PerlIO_printf(Perl_debug_log,
3517 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3518 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3519 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3524 while (cnt > 0) { /* this | eat */
3526 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3527 goto thats_all_folks; /* screams | sed :-) */
3531 Copy(ptr, bp, cnt, char); /* this | eat */
3532 bp += cnt; /* screams | dust */
3533 ptr += cnt; /* louder | sed :-) */
3538 if (shortbuffered) { /* oh well, must extend */
3539 cnt = shortbuffered;
3541 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3543 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3544 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3548 DEBUG_P(PerlIO_printf(Perl_debug_log,
3549 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3550 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3551 DEBUG_P(PerlIO_printf(Perl_debug_log,
3552 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3553 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3554 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3555 /* This used to call 'filbuf' in stdio form, but as that behaves like
3556 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3557 another abstraction. */
3558 i = PerlIO_getc(fp); /* get more characters */
3559 DEBUG_P(PerlIO_printf(Perl_debug_log,
3560 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3561 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3562 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3563 cnt = PerlIO_get_cnt(fp);
3564 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3565 DEBUG_P(PerlIO_printf(Perl_debug_log,
3566 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3568 if (i == EOF) /* all done for ever? */
3569 goto thats_really_all_folks;
3571 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3573 SvGROW(sv, bpx + cnt + 2);
3574 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3576 *bp++ = i; /* store character from PerlIO_getc */
3578 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3579 goto thats_all_folks;
3583 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3584 memNE((char*)bp - rslen, rsptr, rslen))
3585 goto screamer; /* go back to the fray */
3586 thats_really_all_folks:
3588 cnt += shortbuffered;
3589 DEBUG_P(PerlIO_printf(Perl_debug_log,
3590 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3591 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3592 DEBUG_P(PerlIO_printf(Perl_debug_log,
3593 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3594 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3595 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3597 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3598 DEBUG_P(PerlIO_printf(Perl_debug_log,
3599 "Screamer: done, len=%ld, string=|%.*s|\n",
3600 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3605 /*The big, slow, and stupid way */
3608 /* Need to work around EPOC SDK features */
3609 /* On WINS: MS VC5 generates calls to _chkstk, */
3610 /* if a `large' stack frame is allocated */
3611 /* gcc on MARM does not generate calls like these */
3617 register STDCHAR *bpe = buf + sizeof(buf);
3619 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3620 ; /* keep reading */
3624 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3625 /* Accomodate broken VAXC compiler, which applies U8 cast to
3626 * both args of ?: operator, causing EOF to change into 255
3628 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3632 sv_catpvn(sv, (char *) buf, cnt);
3634 sv_setpvn(sv, (char *) buf, cnt);
3636 if (i != EOF && /* joy */
3638 SvCUR(sv) < rslen ||
3639 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3643 * If we're reading from a TTY and we get a short read,
3644 * indicating that the user hit his EOF character, we need
3645 * to notice it now, because if we try to read from the TTY
3646 * again, the EOF condition will disappear.
3648 * The comparison of cnt to sizeof(buf) is an optimization
3649 * that prevents unnecessary calls to feof().
3653 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3658 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3659 while (i != EOF) { /* to make sure file boundaries work right */
3660 i = PerlIO_getc(fp);
3662 PerlIO_ungetc(fp,i);
3669 win32_strip_return(sv);
3672 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3677 Perl_sv_inc(pTHX_ register SV *sv)
3686 if (SvTHINKFIRST(sv)) {
3687 if (SvREADONLY(sv)) {
3689 if (PL_curcop != &PL_compiling)
3690 Perl_croak(aTHX_ PL_no_modify);
3694 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3696 i = PTR2IV(SvRV(sv));
3701 flags = SvFLAGS(sv);
3702 if (flags & SVp_NOK) {
3703 (void)SvNOK_only(sv);
3707 if (flags & SVp_IOK) {
3709 if (SvUVX(sv) == UV_MAX)
3710 sv_setnv(sv, (NV)UV_MAX + 1.0);
3712 (void)SvIOK_only_UV(sv);
3715 if (SvIVX(sv) == IV_MAX)
3716 sv_setnv(sv, (NV)IV_MAX + 1.0);
3718 (void)SvIOK_only(sv);
3724 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3725 if ((flags & SVTYPEMASK) < SVt_PVNV)
3726 sv_upgrade(sv, SVt_NV);
3728 (void)SvNOK_only(sv);
3732 while (isALPHA(*d)) d++;
3733 while (isDIGIT(*d)) d++;
3735 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
3739 while (d >= SvPVX(sv)) {
3747 /* MKS: The original code here died if letters weren't consecutive.
3748 * at least it didn't have to worry about non-C locales. The
3749 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3750 * arranged in order (although not consecutively) and that only
3751 * [A-Za-z] are accepted by isALPHA in the C locale.
3753 if (*d != 'z' && *d != 'Z') {
3754 do { ++*d; } while (!isALPHA(*d));
3757 *(d--) -= 'z' - 'a';
3762 *(d--) -= 'z' - 'a' + 1;
3766 /* oh,oh, the number grew */
3767 SvGROW(sv, SvCUR(sv) + 2);
3769 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3778 Perl_sv_dec(pTHX_ register SV *sv)
3786 if (SvTHINKFIRST(sv)) {
3787 if (SvREADONLY(sv)) {
3789 if (PL_curcop != &PL_compiling)
3790 Perl_croak(aTHX_ PL_no_modify);
3794 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3796 i = PTR2IV(SvRV(sv));
3801 flags = SvFLAGS(sv);
3802 if (flags & SVp_NOK) {
3804 (void)SvNOK_only(sv);
3807 if (flags & SVp_IOK) {
3809 if (SvUVX(sv) == 0) {
3810 (void)SvIOK_only(sv);
3814 (void)SvIOK_only_UV(sv);
3818 if (SvIVX(sv) == IV_MIN)
3819 sv_setnv(sv, (NV)IV_MIN - 1.0);
3821 (void)SvIOK_only(sv);
3827 if (!(flags & SVp_POK)) {
3828 if ((flags & SVTYPEMASK) < SVt_PVNV)
3829 sv_upgrade(sv, SVt_NV);
3831 (void)SvNOK_only(sv);
3834 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
3837 /* Make a string that will exist for the duration of the expression
3838 * evaluation. Actually, it may have to last longer than that, but
3839 * hopefully we won't free it until it has been assigned to a
3840 * permanent location. */
3843 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3849 sv_setsv(sv,oldstr);
3851 PL_tmps_stack[++PL_tmps_ix] = sv;
3857 Perl_sv_newmortal(pTHX)
3863 SvFLAGS(sv) = SVs_TEMP;
3865 PL_tmps_stack[++PL_tmps_ix] = sv;
3869 /* same thing without the copying */
3872 Perl_sv_2mortal(pTHX_ register SV *sv)
3877 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3880 PL_tmps_stack[++PL_tmps_ix] = sv;
3886 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3893 sv_setpvn(sv,s,len);
3898 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3903 sv_setpvn(sv,s,len);
3907 #if defined(PERL_IMPLICIT_CONTEXT)
3909 Perl_newSVpvf_nocontext(const char* pat, ...)
3914 va_start(args, pat);
3915 sv = vnewSVpvf(pat, &args);
3922 Perl_newSVpvf(pTHX_ const char* pat, ...)
3926 va_start(args, pat);
3927 sv = vnewSVpvf(pat, &args);
3933 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
3937 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
3942 Perl_newSVnv(pTHX_ NV n)
3952 Perl_newSViv(pTHX_ IV i)
3962 Perl_newRV_noinc(pTHX_ SV *tmpRef)
3968 sv_upgrade(sv, SVt_RV);
3976 Perl_newRV(pTHX_ SV *tmpRef)
3978 return newRV_noinc(SvREFCNT_inc(tmpRef));
3981 /* make an exact duplicate of old */
3984 Perl_newSVsv(pTHX_ register SV *old)
3991 if (SvTYPE(old) == SVTYPEMASK) {
3992 if (ckWARN_d(WARN_INTERNAL))
3993 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4008 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4016 char todo[PERL_UCHAR_MAX+1];
4021 if (!*s) { /* reset ?? searches */
4022 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4023 pm->op_pmdynflags &= ~PMdf_USED;
4028 /* reset variables */
4030 if (!HvARRAY(stash))
4033 Zero(todo, 256, char);
4035 i = (unsigned char)*s;
4039 max = (unsigned char)*s++;
4040 for ( ; i <= max; i++) {
4043 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4044 for (entry = HvARRAY(stash)[i];
4046 entry = HeNEXT(entry))
4048 if (!todo[(U8)*HeKEY(entry)])
4050 gv = (GV*)HeVAL(entry);
4052 if (SvTHINKFIRST(sv)) {
4053 if (!SvREADONLY(sv) && SvROK(sv))
4058 if (SvTYPE(sv) >= SVt_PV) {
4060 if (SvPVX(sv) != Nullch)
4067 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4069 #ifndef VMS /* VMS has no environ array */
4071 environ[0] = Nullch;
4080 Perl_sv_2io(pTHX_ SV *sv)
4086 switch (SvTYPE(sv)) {
4094 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4098 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4100 return sv_2io(SvRV(sv));
4101 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4107 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4114 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4121 return *gvp = Nullgv, Nullcv;
4122 switch (SvTYPE(sv)) {
4142 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4143 tryAMAGICunDEREF(to_cv);
4146 if (SvTYPE(sv) == SVt_PVCV) {
4155 Perl_croak(aTHX_ "Not a subroutine reference");
4160 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4166 if (lref && !GvCVu(gv)) {
4169 tmpsv = NEWSV(704,0);
4170 gv_efullname3(tmpsv, gv, Nullch);
4171 /* XXX this is probably not what they think they're getting.
4172 * It has the same effect as "sub name;", i.e. just a forward
4174 newSUB(start_subparse(FALSE, 0),
4175 newSVOP(OP_CONST, 0, tmpsv),
4180 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4187 Perl_sv_true(pTHX_ register SV *sv)
4194 if ((tXpv = (XPV*)SvANY(sv)) &&
4195 (*tXpv->xpv_pv > '0' ||
4196 tXpv->xpv_cur > 1 ||
4197 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4204 return SvIVX(sv) != 0;
4207 return SvNVX(sv) != 0.0;
4209 return sv_2bool(sv);
4215 Perl_sv_iv(pTHX_ register SV *sv)
4219 return (IV)SvUVX(sv);
4226 Perl_sv_uv(pTHX_ register SV *sv)
4231 return (UV)SvIVX(sv);
4237 Perl_sv_nv(pTHX_ register SV *sv)
4245 Perl_sv_pv(pTHX_ SV *sv)
4252 return sv_2pv(sv, &n_a);
4256 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4262 return sv_2pv(sv, lp);
4266 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4270 if (SvTHINKFIRST(sv) && !SvROK(sv))
4271 sv_force_normal(sv);
4277 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4279 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4280 PL_op_name[PL_op->op_type]);
4284 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4289 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4290 SvGROW(sv, len + 1);
4291 Move(s,SvPVX(sv),len,char);
4296 SvPOK_on(sv); /* validate pointer */
4298 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4299 (unsigned long)sv,SvPVX(sv)));
4306 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4308 if (ob && SvOBJECT(sv))
4309 return HvNAME(SvSTASH(sv));
4311 switch (SvTYPE(sv)) {
4325 case SVt_PVLV: return "LVALUE";
4326 case SVt_PVAV: return "ARRAY";
4327 case SVt_PVHV: return "HASH";
4328 case SVt_PVCV: return "CODE";
4329 case SVt_PVGV: return "GLOB";
4330 case SVt_PVFM: return "FORMAT";
4331 default: return "UNKNOWN";
4337 Perl_sv_isobject(pTHX_ SV *sv)
4352 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4364 return strEQ(HvNAME(SvSTASH(sv)), name);
4368 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4375 SV_CHECK_THINKFIRST(rv);
4378 if (SvTYPE(rv) < SVt_RV)
4379 sv_upgrade(rv, SVt_RV);
4386 HV* stash = gv_stashpv(classname, TRUE);
4387 (void)sv_bless(rv, stash);
4393 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4396 sv_setsv(rv, &PL_sv_undef);
4400 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4405 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4407 sv_setiv(newSVrv(rv,classname), iv);
4412 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4414 sv_setnv(newSVrv(rv,classname), nv);
4419 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4421 sv_setpvn(newSVrv(rv,classname), pv, n);
4426 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4431 Perl_croak(aTHX_ "Can't bless non-reference value");
4433 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4434 if (SvREADONLY(tmpRef))
4435 Perl_croak(aTHX_ PL_no_modify);
4436 if (SvOBJECT(tmpRef)) {
4437 if (SvTYPE(tmpRef) != SVt_PVIO)
4439 SvREFCNT_dec(SvSTASH(tmpRef));
4442 SvOBJECT_on(tmpRef);
4443 if (SvTYPE(tmpRef) != SVt_PVIO)
4445 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4446 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4457 S_sv_unglob(pTHX_ SV *sv)
4459 assert(SvTYPE(sv) == SVt_PVGV);
4464 SvREFCNT_dec(GvSTASH(sv));
4465 GvSTASH(sv) = Nullhv;
4467 sv_unmagic(sv, '*');
4468 Safefree(GvNAME(sv));
4470 SvFLAGS(sv) &= ~SVTYPEMASK;
4471 SvFLAGS(sv) |= SVt_PVMG;
4475 Perl_sv_unref(pTHX_ SV *sv)
4479 if (SvWEAKREF(sv)) {
4487 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4490 sv_2mortal(rv); /* Schedule for freeing later */
4494 Perl_sv_taint(pTHX_ SV *sv)
4496 sv_magic((sv), Nullsv, 't', Nullch, 0);
4500 Perl_sv_untaint(pTHX_ SV *sv)
4502 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4503 MAGIC *mg = mg_find(sv, 't');
4510 Perl_sv_tainted(pTHX_ SV *sv)
4512 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4513 MAGIC *mg = mg_find(sv, 't');
4514 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4521 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4523 char buf[TYPE_CHARS(UV)];
4525 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4527 sv_setpvn(sv, ptr, ebuf - ptr);
4532 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4534 char buf[TYPE_CHARS(UV)];
4536 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4538 sv_setpvn(sv, ptr, ebuf - ptr);
4542 #if defined(PERL_IMPLICIT_CONTEXT)
4544 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4548 va_start(args, pat);
4549 sv_vsetpvf(sv, pat, &args);
4555 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4559 va_start(args, pat);
4560 sv_vsetpvf_mg(sv, pat, &args);
4566 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4569 va_start(args, pat);
4570 sv_vsetpvf(sv, pat, &args);
4575 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4577 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4581 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4584 va_start(args, pat);
4585 sv_vsetpvf_mg(sv, pat, &args);
4590 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4592 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4596 #if defined(PERL_IMPLICIT_CONTEXT)
4598 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4602 va_start(args, pat);
4603 sv_vcatpvf(sv, pat, &args);
4608 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4612 va_start(args, pat);
4613 sv_vcatpvf_mg(sv, pat, &args);
4619 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4622 va_start(args, pat);
4623 sv_vcatpvf(sv, pat, &args);
4628 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4630 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4634 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4637 va_start(args, pat);
4638 sv_vcatpvf_mg(sv, pat, &args);
4643 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4645 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4650 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
4652 sv_setpvn(sv, "", 0);
4653 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
4657 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
4665 static char nullstr[] = "(null)";
4667 /* no matter what, this is a string now */
4668 (void)SvPV_force(sv, origlen);
4670 /* special-case "", "%s", and "%_" */
4673 if (patlen == 2 && pat[0] == '%') {
4677 char *s = va_arg(*args, char*);
4678 sv_catpv(sv, s ? s : nullstr);
4680 else if (svix < svmax)
4681 sv_catsv(sv, *svargs);
4685 sv_catsv(sv, va_arg(*args, SV*));
4688 /* See comment on '_' below */
4693 patend = (char*)pat + patlen;
4694 for (p = (char*)pat; p < patend; p = q) {
4702 bool has_precis = FALSE;
4707 STRLEN esignlen = 0;
4709 char *eptr = Nullch;
4711 /* Times 4: a decimal digit takes more than 3 binary digits.
4712 * NV_DIG: mantissa takes than many decimal digits.
4713 * Plus 32: Playing safe. */
4714 char ebuf[IV_DIG * 4 + NV_DIG + 32];
4715 /* large enough for "%#.#f" --chip */
4716 /* what about long double NVs? --jhi */
4727 for (q = p; q < patend && *q != '%'; ++q) ;
4729 sv_catpvn(sv, p, q - p);
4767 case '1': case '2': case '3':
4768 case '4': case '5': case '6':
4769 case '7': case '8': case '9':
4772 width = width * 10 + (*q++ - '0');
4777 i = va_arg(*args, int);
4779 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4781 width = (i < 0) ? -i : i;
4792 i = va_arg(*args, int);
4794 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4795 precis = (i < 0) ? 0 : i;
4801 precis = precis * 10 + (*q++ - '0');
4811 if (*(q + 1) == 'l') { /* lld */
4843 uv = va_arg(*args, int);
4845 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4847 eptr = (char*)utf8buf;
4848 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4852 c = va_arg(*args, int);
4854 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4861 eptr = va_arg(*args, char*);
4863 elen = strlen(eptr);
4866 elen = sizeof nullstr - 1;
4869 else if (svix < svmax) {
4870 eptr = SvPVx(svargs[svix++], elen);
4872 if (has_precis && precis < elen) {
4874 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4877 if (width) { /* fudge width (can't fudge elen) */
4878 width += elen - sv_len_utf8(svargs[svix - 1]);
4886 * The "%_" hack might have to be changed someday,
4887 * if ISO or ANSI decide to use '_' for something.
4888 * So we keep it hidden from users' code.
4892 eptr = SvPVx(va_arg(*args, SV*), elen);
4895 if (has_precis && elen > precis)
4903 uv = PTR2UV(va_arg(*args, void*));
4905 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
4920 case 'h': iv = (short)va_arg(*args, int); break;
4921 default: iv = va_arg(*args, int); break;
4922 case 'l': iv = va_arg(*args, long); break;
4923 case 'V': iv = va_arg(*args, IV); break;
4925 case 'q': iv = va_arg(*args, Quad_t); break;
4930 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4932 case 'h': iv = (short)iv; break;
4933 default: iv = (int)iv; break;
4934 case 'l': iv = (long)iv; break;
4937 case 'q': iv = (Quad_t)iv; break;
4944 esignbuf[esignlen++] = plus;
4948 esignbuf[esignlen++] = '-';
4986 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4987 default: uv = va_arg(*args, unsigned); break;
4988 case 'l': uv = va_arg(*args, unsigned long); break;
4989 case 'V': uv = va_arg(*args, UV); break;
4991 case 'q': uv = va_arg(*args, Quad_t); break;
4996 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4998 case 'h': uv = (unsigned short)uv; break;
4999 default: uv = (unsigned)uv; break;
5000 case 'l': uv = (unsigned long)uv; break;
5003 case 'q': uv = (Quad_t)uv; break;
5009 eptr = ebuf + sizeof ebuf;
5015 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5021 esignbuf[esignlen++] = '0';
5022 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5028 *--eptr = '0' + dig;
5030 if (alt && *eptr != '0')
5036 *--eptr = '0' + dig;
5039 esignbuf[esignlen++] = '0';
5040 esignbuf[esignlen++] = 'b';
5043 default: /* it had better be ten or less */
5044 #if defined(PERL_Y2KWARN)
5045 if (ckWARN(WARN_MISC)) {
5047 char *s = SvPV(sv,n);
5048 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5049 && (n == 2 || !isDIGIT(s[n-3])))
5051 Perl_warner(aTHX_ WARN_MISC,
5052 "Possible Y2K bug: %%%c %s",
5053 c, "format string following '19'");
5059 *--eptr = '0' + dig;
5060 } while (uv /= base);
5063 elen = (ebuf + sizeof ebuf) - eptr;
5066 zeros = precis - elen;
5067 else if (precis == 0 && elen == 1 && *eptr == '0')
5072 /* FLOATING POINT */
5075 c = 'f'; /* maybe %F isn't supported here */
5081 /* This is evil, but floating point is even more evil */
5084 nv = va_arg(*args, NV);
5086 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5089 if (c != 'e' && c != 'E') {
5091 (void)frexp(nv, &i);
5092 if (i == PERL_INT_MIN)
5093 Perl_die(aTHX_ "panic: frexp");
5095 need = BIT_DIGITS(i);
5097 need += has_precis ? precis : 6; /* known default */
5101 need += 20; /* fudge factor */
5102 if (PL_efloatsize < need) {
5103 Safefree(PL_efloatbuf);
5104 PL_efloatsize = need + 20; /* more fudge */
5105 New(906, PL_efloatbuf, PL_efloatsize, char);
5106 PL_efloatbuf[0] = '\0';
5109 eptr = ebuf + sizeof ebuf;
5112 #ifdef USE_LONG_DOUBLE
5114 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5115 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5120 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5125 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5138 RESTORE_NUMERIC_STANDARD();
5139 (void)sprintf(PL_efloatbuf, eptr, nv);
5140 RESTORE_NUMERIC_LOCAL();
5143 eptr = PL_efloatbuf;
5144 elen = strlen(PL_efloatbuf);
5146 #ifdef USE_LOCALE_NUMERIC
5148 * User-defined locales may include arbitrary characters.
5149 * And, unfortunately, some (broken) systems may allow the
5150 * "C" locale to be overridden by a malicious user.
5151 * XXX This is an extreme way to cope with broken systems.
5153 if (maybe_tainted && PL_tainting) {
5154 /* safe if it matches /[-+]?\d*(\.\d*)?([eE][-+]?\d*)?/ */
5155 if (*eptr == '-' || *eptr == '+')
5157 while (isDIGIT(*eptr))
5161 while (isDIGIT(*eptr))
5164 if (*eptr == 'e' || *eptr == 'E') {
5166 if (*eptr == '-' || *eptr == '+')
5168 while (isDIGIT(*eptr))
5172 *maybe_tainted = TRUE; /* results are suspect */
5173 eptr = PL_efloatbuf;
5175 #endif /* USE_LOCALE_NUMERIC */
5182 i = SvCUR(sv) - origlen;
5185 case 'h': *(va_arg(*args, short*)) = i; break;
5186 default: *(va_arg(*args, int*)) = i; break;
5187 case 'l': *(va_arg(*args, long*)) = i; break;
5188 case 'V': *(va_arg(*args, IV*)) = i; break;
5190 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5194 else if (svix < svmax)
5195 sv_setuv(svargs[svix++], (UV)i);
5196 continue; /* not "break" */
5202 if (!args && ckWARN(WARN_PRINTF) &&
5203 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5204 SV *msg = sv_newmortal();
5205 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5206 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5210 Perl_sv_catpvf(aTHX_ msg,
5211 "\"%%%c\"", c & 0xFF);
5213 Perl_sv_catpvf(aTHX_ msg,
5214 "\"%%\\%03" PERL_PRIo64 "\"",
5217 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ?
5218 "\"%%%c\"" : "\"%%\\%03o\"",
5222 sv_catpv(msg, "end of string");
5223 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5226 /* output mangled stuff ... */
5232 /* ... right here, because formatting flags should not apply */
5233 SvGROW(sv, SvCUR(sv) + elen + 1);
5235 memcpy(p, eptr, elen);
5238 SvCUR(sv) = p - SvPVX(sv);
5239 continue; /* not "break" */
5242 have = esignlen + zeros + elen;
5243 need = (have > width ? have : width);
5246 SvGROW(sv, SvCUR(sv) + need + 1);
5248 if (esignlen && fill == '0') {
5249 for (i = 0; i < esignlen; i++)
5253 memset(p, fill, gap);
5256 if (esignlen && fill != '0') {
5257 for (i = 0; i < esignlen; i++)
5261 for (i = zeros; i; i--)
5265 memcpy(p, eptr, elen);
5269 memset(p, ' ', gap);
5273 SvCUR(sv) = p - SvPVX(sv);
5284 do_report_used(pTHXo_ SV *sv)
5286 if (SvTYPE(sv) != SVTYPEMASK) {
5287 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
5288 PerlIO_printf(PerlIO_stderr(), "****\n");
5294 do_clean_objs(pTHXo_ SV *sv)
5298 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5299 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
5305 /* XXX Might want to check arrays, etc. */
5308 #ifndef DISABLE_DESTRUCTOR_KLUDGE
5310 do_clean_named_objs(pTHXo_ SV *sv)
5312 if (SvTYPE(sv) == SVt_PVGV) {
5313 if ( SvOBJECT(GvSV(sv)) ||
5314 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
5315 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
5316 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
5317 GvCV(sv) && SvOBJECT(GvCV(sv)) )
5319 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
5327 do_clean_all(pTHXo_ SV *sv)
5329 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
5330 SvFLAGS(sv) |= SVf_BREAK;