3 * Copyright (c) 1991-1999, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
19 /* Use an overridden DBL_DIG */
23 # define DBL_DIG OVR_DBL_DIG
25 /* The following is all to get DBL_DIG, in order to pick a nice
26 default value for printing floating point numbers in Gconvert.
36 #define DBL_DIG 15 /* A guess that works lots of places */
41 #define VTBL this->*vtbl
42 #else /* !PERL_OBJECT */
44 #endif /* PERL_OBJECT */
47 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
49 static void do_report_used(pTHXo_ SV *sv);
50 static void do_clean_objs(pTHXo_ SV *sv);
51 #ifndef DISABLE_DESTRUCTOR_KLUDGE
52 static void do_clean_named_objs(pTHXo_ SV *sv);
54 static void do_clean_all(pTHXo_ SV *sv);
62 (p) = (SV*)safemalloc(sizeof(SV)); \
74 Safefree((char*)(p)); \
79 static I32 registry_size;
81 #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
83 #define REG_REPLACE(sv,a,b) \
85 void* p = sv->sv_any; \
86 I32 h = REGHASH(sv, registry_size); \
88 while (registry[i] != (a)) { \
89 if (++i >= registry_size) \
92 Perl_die(aTHX_ "SV registry bug"); \
97 #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
98 #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
101 S_reg_add(pTHX_ SV *sv)
103 if (PL_sv_count >= (registry_size >> 1))
105 SV **oldreg = registry;
106 I32 oldsize = registry_size;
108 registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
109 Newz(707, registry, registry_size, SV*);
114 for (i = 0; i < oldsize; ++i) {
115 SV* oldsv = oldreg[i];
128 S_reg_remove(pTHX_ SV *sv)
135 S_visit(pTHX_ SVFUNC_t f)
139 for (i = 0; i < registry_size; ++i) {
140 SV* sv = registry[i];
141 if (sv && SvTYPE(sv) != SVTYPEMASK)
147 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
149 if (!(flags & SVf_FAKE))
156 * "A time to plant, and a time to uproot what was planted..."
159 #define plant_SV(p) \
161 SvANY(p) = (void *)PL_sv_root; \
162 SvFLAGS(p) = SVTYPEMASK; \
167 /* sv_mutex must be held while calling uproot_SV() */
168 #define uproot_SV(p) \
171 PL_sv_root = (SV*)SvANY(p); \
193 if (PL_debug & 32768) \
201 S_del_sv(pTHX_ SV *p)
203 if (PL_debug & 32768) {
208 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
210 svend = &sva[SvREFCNT(sva)];
211 if (p >= sv && p < svend)
215 if (ckWARN_d(WARN_INTERNAL))
216 Perl_warner(aTHX_ WARN_INTERNAL,
217 "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
224 #else /* ! DEBUGGING */
226 #define del_SV(p) plant_SV(p)
228 #endif /* DEBUGGING */
231 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
236 Zero(sva, size, char);
238 /* The first SV in an arena isn't an SV. */
239 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
240 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
241 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
243 PL_sv_arenaroot = sva;
244 PL_sv_root = sva + 1;
246 svend = &sva[SvREFCNT(sva) - 1];
249 SvANY(sv) = (void *)(SV*)(sv + 1);
250 SvFLAGS(sv) = SVTYPEMASK;
254 SvFLAGS(sv) = SVTYPEMASK;
257 /* sv_mutex must be held while calling more_sv() */
264 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
265 PL_nice_chunk = Nullch;
268 char *chunk; /* must use New here to match call to */
269 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
270 sv_add_arena(chunk, 1008, 0);
277 S_visit(pTHX_ SVFUNC_t f)
283 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
284 svend = &sva[SvREFCNT(sva)];
285 for (sv = sva + 1; sv < svend; ++sv) {
286 if (SvTYPE(sv) != SVTYPEMASK)
295 Perl_sv_report_used(pTHX)
297 visit(do_report_used);
301 Perl_sv_clean_objs(pTHX)
303 PL_in_clean_objs = TRUE;
304 visit(do_clean_objs);
305 #ifndef DISABLE_DESTRUCTOR_KLUDGE
306 /* some barnacles may yet remain, clinging to typeglobs */
307 visit(do_clean_named_objs);
309 PL_in_clean_objs = FALSE;
313 Perl_sv_clean_all(pTHX)
315 PL_in_clean_all = TRUE;
317 PL_in_clean_all = FALSE;
321 Perl_sv_free_arenas(pTHX)
326 /* Free arenas here, but be careful about fake ones. (We assume
327 contiguity of the fake ones with the corresponding real ones.) */
329 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
330 svanext = (SV*) SvANY(sva);
331 while (svanext && SvFAKE(svanext))
332 svanext = (SV*) SvANY(svanext);
335 Safefree((void *)sva);
339 Safefree(PL_nice_chunk);
340 PL_nice_chunk = Nullch;
341 PL_nice_chunk_size = 0;
355 * See comment in more_xiv() -- RAM.
357 PL_xiv_root = *(IV**)xiv;
359 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
363 S_del_xiv(pTHX_ XPVIV *p)
365 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
367 *(IV**)xiv = PL_xiv_root;
378 New(705, ptr, 1008/sizeof(XPV), XPV);
379 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
380 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
383 xivend = &xiv[1008 / sizeof(IV) - 1];
384 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
386 while (xiv < xivend) {
387 *(IV**)xiv = (IV *)(xiv + 1);
401 PL_xnv_root = *(NV**)xnv;
403 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
407 S_del_xnv(pTHX_ XPVNV *p)
409 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
411 *(NV**)xnv = PL_xnv_root;
421 New(711, xnv, 1008/sizeof(NV), NV);
422 xnvend = &xnv[1008 / sizeof(NV) - 1];
423 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
425 while (xnv < xnvend) {
426 *(NV**)xnv = (NV*)(xnv + 1);
440 PL_xrv_root = (XRV*)xrv->xrv_rv;
446 S_del_xrv(pTHX_ XRV *p)
449 p->xrv_rv = (SV*)PL_xrv_root;
458 register XRV* xrvend;
459 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
461 xrvend = &xrv[1008 / sizeof(XRV) - 1];
462 while (xrv < xrvend) {
463 xrv->xrv_rv = (SV*)(xrv + 1);
477 PL_xpv_root = (XPV*)xpv->xpv_pv;
483 S_del_xpv(pTHX_ XPV *p)
486 p->xpv_pv = (char*)PL_xpv_root;
495 register XPV* xpvend;
496 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
498 xpvend = &xpv[1008 / sizeof(XPV) - 1];
499 while (xpv < xpvend) {
500 xpv->xpv_pv = (char*)(xpv + 1);
507 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
508 #define del_XIV(p) Safefree((char*)p)
510 #define new_XIV() (void*)new_xiv()
511 #define del_XIV(p) del_xiv((XPVIV*) p)
515 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
516 #define del_XNV(p) Safefree((char*)p)
518 #define new_XNV() (void*)new_xnv()
519 #define del_XNV(p) del_xnv((XPVNV*) p)
523 #define new_XRV() (void*)safemalloc(sizeof(XRV))
524 #define del_XRV(p) Safefree((char*)p)
526 #define new_XRV() (void*)new_xrv()
527 #define del_XRV(p) del_xrv((XRV*) p)
531 #define new_XPV() (void*)safemalloc(sizeof(XPV))
532 #define del_XPV(p) Safefree((char*)p)
534 #define new_XPV() (void*)new_xpv()
535 #define del_XPV(p) del_xpv((XPV *)p)
539 # define my_safemalloc(s) safemalloc(s)
540 # define my_safefree(s) safefree(s)
543 S_my_safemalloc(MEM_SIZE size)
546 New(717, p, size, char);
549 # define my_safefree(s) Safefree(s)
552 #define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
553 #define del_XPVIV(p) my_safefree((char*)p)
555 #define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
556 #define del_XPVNV(p) my_safefree((char*)p)
558 #define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
559 #define del_XPVMG(p) my_safefree((char*)p)
561 #define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
562 #define del_XPVLV(p) my_safefree((char*)p)
564 #define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
565 #define del_XPVAV(p) my_safefree((char*)p)
567 #define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
568 #define del_XPVHV(p) my_safefree((char*)p)
570 #define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
571 #define del_XPVCV(p) my_safefree((char*)p)
573 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
574 #define del_XPVGV(p) my_safefree((char*)p)
576 #define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
577 #define del_XPVBM(p) my_safefree((char*)p)
579 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
580 #define del_XPVFM(p) my_safefree((char*)p)
582 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
583 #define del_XPVIO(p) my_safefree((char*)p)
586 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
596 if (SvTYPE(sv) == mt)
602 switch (SvTYPE(sv)) {
623 else if (mt < SVt_PVIV)
640 pv = (char*)SvRV(sv);
644 nv = (NV)(unsigned long)pv;
660 else if (mt == SVt_NV)
671 del_XPVIV(SvANY(sv));
681 del_XPVNV(SvANY(sv));
691 del_XPVMG(SvANY(sv));
694 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
699 Perl_croak(aTHX_ "Can't upgrade to undef");
701 SvANY(sv) = new_XIV();
705 SvANY(sv) = new_XNV();
709 SvANY(sv) = new_XRV();
713 SvANY(sv) = new_XPV();
719 SvANY(sv) = new_XPVIV();
729 SvANY(sv) = new_XPVNV();
737 SvANY(sv) = new_XPVMG();
747 SvANY(sv) = new_XPVLV();
761 SvANY(sv) = new_XPVAV();
776 SvANY(sv) = new_XPVHV();
792 SvANY(sv) = new_XPVCV();
793 Zero(SvANY(sv), 1, XPVCV);
803 SvANY(sv) = new_XPVGV();
818 SvANY(sv) = new_XPVBM();
831 SvANY(sv) = new_XPVFM();
832 Zero(SvANY(sv), 1, XPVFM);
842 SvANY(sv) = new_XPVIO();
843 Zero(SvANY(sv), 1, XPVIO);
854 SvFLAGS(sv) &= ~SVTYPEMASK;
860 Perl_sv_backoff(pTHX_ register SV *sv)
865 SvLEN(sv) += SvIVX(sv);
866 SvPVX(sv) -= SvIVX(sv);
868 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
870 SvFLAGS(sv) &= ~SVf_OOK;
875 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
880 if (newlen >= 0x10000) {
881 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
884 #endif /* HAS_64K_LIMIT */
887 if (SvTYPE(sv) < SVt_PV) {
888 sv_upgrade(sv, SVt_PV);
891 else if (SvOOK(sv)) { /* pv is offset? */
894 if (newlen > SvLEN(sv))
895 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
897 if (newlen >= 0x10000)
903 if (newlen > SvLEN(sv)) { /* need more room? */
904 if (SvLEN(sv) && s) {
905 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
906 STRLEN l = malloced_size((void*)SvPVX(sv));
912 Renew(s,newlen,char);
915 New(703,s,newlen,char);
917 SvLEN_set(sv, newlen);
923 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
925 SV_CHECK_THINKFIRST(sv);
926 switch (SvTYPE(sv)) {
928 sv_upgrade(sv, SVt_IV);
931 sv_upgrade(sv, SVt_PVNV);
935 sv_upgrade(sv, SVt_PVIV);
946 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
947 PL_op_desc[PL_op->op_type]);
950 (void)SvIOK_only(sv); /* validate number */
956 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
963 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
971 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
978 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
980 SV_CHECK_THINKFIRST(sv);
981 switch (SvTYPE(sv)) {
984 sv_upgrade(sv, SVt_NV);
989 sv_upgrade(sv, SVt_PVNV);
1000 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1001 PL_op_name[PL_op->op_type]);
1005 (void)SvNOK_only(sv); /* validate number */
1010 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1017 S_not_a_number(pTHX_ SV *sv)
1023 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1024 /* each *s can expand to 4 chars + "...\0",
1025 i.e. need room for 8 chars */
1027 for (s = SvPVX(sv); *s && d < limit; s++) {
1029 if (ch & 128 && !isPRINT_LC(ch)) {
1038 else if (ch == '\r') {
1042 else if (ch == '\f') {
1046 else if (ch == '\\') {
1050 else if (isPRINT_LC(ch))
1065 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
1066 PL_op_name[PL_op->op_type]);
1068 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
1071 /* the number can be converted to _integer_ with atol() */
1072 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1073 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1074 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1075 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1077 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1078 until proven guilty, assume that things are not that bad... */
1081 Perl_sv_2iv(pTHX_ register SV *sv)
1085 if (SvGMAGICAL(sv)) {
1090 return I_V(SvNVX(sv));
1092 if (SvPOKp(sv) && SvLEN(sv))
1095 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1097 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1098 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1103 if (SvTHINKFIRST(sv)) {
1106 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1107 return SvIV(tmpstr);
1108 return (IV)SvRV(sv);
1110 if (SvREADONLY(sv) && !SvOK(sv)) {
1112 if (ckWARN(WARN_UNINITIALIZED))
1113 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1119 return (IV)(SvUVX(sv));
1126 /* We can cache the IV/UV value even if it not good enough
1127 * to reconstruct NV, since the conversion to PV will prefer
1128 * NV over IV/UV. XXXX 64-bit?
1131 if (SvTYPE(sv) == SVt_NV)
1132 sv_upgrade(sv, SVt_PVNV);
1135 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1136 SvIVX(sv) = I_V(SvNVX(sv));
1138 SvUVX(sv) = U_V(SvNVX(sv));
1141 DEBUG_c(PerlIO_printf(Perl_debug_log,
1142 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1144 (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
1145 return (IV)SvUVX(sv);
1148 else if (SvPOKp(sv) && SvLEN(sv)) {
1149 I32 numtype = looks_like_number(sv);
1151 /* We want to avoid a possible problem when we cache an IV which
1152 may be later translated to an NV, and the resulting NV is not
1153 the translation of the initial data.
1155 This means that if we cache such an IV, we need to cache the
1156 NV as well. Moreover, we trade speed for space, and do not
1157 cache the NV if not needed.
1159 if (numtype & IS_NUMBER_NOT_IV) {
1160 /* May be not an integer. Need to cache NV if we cache IV
1161 * - otherwise future conversion to NV will be wrong. */
1164 d = Atof(SvPVX(sv));
1166 if (SvTYPE(sv) < SVt_PVNV)
1167 sv_upgrade(sv, SVt_PVNV);
1171 #if defined(USE_LONG_DOUBLE)
1172 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1173 (unsigned long)sv, SvNVX(sv)));
1175 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1176 (unsigned long)sv, SvNVX(sv)));
1178 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1179 SvIVX(sv) = I_V(SvNVX(sv));
1181 SvUVX(sv) = U_V(SvNVX(sv));
1187 /* The NV may be reconstructed from IV - safe to cache IV,
1188 which may be calculated by atol(). */
1189 if (SvTYPE(sv) == SVt_PV)
1190 sv_upgrade(sv, SVt_PVIV);
1192 SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
1194 else { /* Not a number. Cache 0. */
1197 if (SvTYPE(sv) < SVt_PVIV)
1198 sv_upgrade(sv, SVt_PVIV);
1201 if (ckWARN(WARN_NUMERIC))
1207 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1208 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1209 if (SvTYPE(sv) < SVt_IV)
1210 /* Typically the caller expects that sv_any is not NULL now. */
1211 sv_upgrade(sv, SVt_IV);
1214 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1215 (unsigned long)sv,(long)SvIVX(sv)));
1216 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1220 Perl_sv_2uv(pTHX_ register SV *sv)
1224 if (SvGMAGICAL(sv)) {
1229 return U_V(SvNVX(sv));
1230 if (SvPOKp(sv) && SvLEN(sv))
1233 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1235 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1236 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1241 if (SvTHINKFIRST(sv)) {
1244 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1245 return SvUV(tmpstr);
1246 return (UV)SvRV(sv);
1248 if (SvREADONLY(sv) && !SvOK(sv)) {
1250 if (ckWARN(WARN_UNINITIALIZED))
1251 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1260 return (UV)SvIVX(sv);
1264 /* We can cache the IV/UV value even if it not good enough
1265 * to reconstruct NV, since the conversion to PV will prefer
1266 * NV over IV/UV. XXXX 64-bit?
1268 if (SvTYPE(sv) == SVt_NV)
1269 sv_upgrade(sv, SVt_PVNV);
1271 if (SvNVX(sv) >= -0.5) {
1273 SvUVX(sv) = U_V(SvNVX(sv));
1276 SvIVX(sv) = I_V(SvNVX(sv));
1278 DEBUG_c(PerlIO_printf(Perl_debug_log,
1279 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1280 (unsigned long)sv,(long)SvIVX(sv),
1281 (long)(UV)SvIVX(sv)));
1282 return (UV)SvIVX(sv);
1285 else if (SvPOKp(sv) && SvLEN(sv)) {
1286 I32 numtype = looks_like_number(sv);
1288 /* We want to avoid a possible problem when we cache a UV which
1289 may be later translated to an NV, and the resulting NV is not
1290 the translation of the initial data.
1292 This means that if we cache such a UV, we need to cache the
1293 NV as well. Moreover, we trade speed for space, and do not
1294 cache the NV if not needed.
1296 if (numtype & IS_NUMBER_NOT_IV) {
1297 /* May be not an integer. Need to cache NV if we cache IV
1298 * - otherwise future conversion to NV will be wrong. */
1301 d = Atof(SvPVX(sv)); /* XXXX 64-bit? */
1303 if (SvTYPE(sv) < SVt_PVNV)
1304 sv_upgrade(sv, SVt_PVNV);
1308 #if defined(USE_LONG_DOUBLE)
1309 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1310 (unsigned long)sv, SvNVX(sv)));
1312 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1313 (unsigned long)sv, SvNVX(sv)));
1315 if (SvNVX(sv) < -0.5) {
1316 SvIVX(sv) = I_V(SvNVX(sv));
1319 SvUVX(sv) = U_V(SvNVX(sv));
1323 else if (numtype & IS_NUMBER_NEG) {
1324 /* The NV may be reconstructed from IV - safe to cache IV,
1325 which may be calculated by atol(). */
1326 if (SvTYPE(sv) == SVt_PV)
1327 sv_upgrade(sv, SVt_PVIV);
1329 SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1331 else if (numtype) { /* Non-negative */
1332 /* The NV may be reconstructed from UV - safe to cache UV,
1333 which may be calculated by strtoul()/atol. */
1334 if (SvTYPE(sv) == SVt_PV)
1335 sv_upgrade(sv, SVt_PVIV);
1337 (void)SvIsUV_on(sv);
1339 SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
1340 #else /* no atou(), but we know the number fits into IV... */
1341 /* The only problem may be if it is negative... */
1342 SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1345 else { /* Not a number. Cache 0. */
1348 if (SvTYPE(sv) < SVt_PVIV)
1349 sv_upgrade(sv, SVt_PVIV);
1350 SvUVX(sv) = 0; /* We assume that 0s have the
1351 same bitmap in IV and UV. */
1353 (void)SvIsUV_on(sv);
1354 if (ckWARN(WARN_NUMERIC))
1359 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1361 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1362 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1364 if (SvTYPE(sv) < SVt_IV)
1365 /* Typically the caller expects that sv_any is not NULL now. */
1366 sv_upgrade(sv, SVt_IV);
1370 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1371 (unsigned long)sv,SvUVX(sv)));
1372 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1376 Perl_sv_2nv(pTHX_ register SV *sv)
1380 if (SvGMAGICAL(sv)) {
1384 if (SvPOKp(sv) && SvLEN(sv)) {
1386 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1388 return Atof(SvPVX(sv));
1392 return (NV)SvUVX(sv);
1394 return (NV)SvIVX(sv);
1397 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1399 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1400 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1405 if (SvTHINKFIRST(sv)) {
1408 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1409 return SvNV(tmpstr);
1410 return (NV)(unsigned long)SvRV(sv);
1412 if (SvREADONLY(sv) && !SvOK(sv)) {
1414 if (ckWARN(WARN_UNINITIALIZED))
1415 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1419 if (SvTYPE(sv) < SVt_NV) {
1420 if (SvTYPE(sv) == SVt_IV)
1421 sv_upgrade(sv, SVt_PVNV);
1423 sv_upgrade(sv, SVt_NV);
1424 #if defined(USE_LONG_DOUBLE)
1426 RESTORE_NUMERIC_STANDARD();
1427 PerlIO_printf(Perl_debug_log, "0x%lx num(%Lg)\n",
1428 (unsigned long)sv, SvNVX(sv));
1429 RESTORE_NUMERIC_LOCAL();
1433 RESTORE_NUMERIC_STANDARD();
1434 PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
1435 (unsigned long)sv, SvNVX(sv));
1436 RESTORE_NUMERIC_LOCAL();
1440 else if (SvTYPE(sv) < SVt_PVNV)
1441 sv_upgrade(sv, SVt_PVNV);
1443 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1445 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1447 else if (SvPOKp(sv) && SvLEN(sv)) {
1449 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1451 SvNVX(sv) = Atof(SvPVX(sv));
1455 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1456 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1457 if (SvTYPE(sv) < SVt_NV)
1458 /* Typically the caller expects that sv_any is not NULL now. */
1459 sv_upgrade(sv, SVt_NV);
1463 #if defined(USE_LONG_DOUBLE)
1465 RESTORE_NUMERIC_STANDARD();
1466 PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1467 (unsigned long)sv, SvNVX(sv));
1468 RESTORE_NUMERIC_LOCAL();
1472 RESTORE_NUMERIC_STANDARD();
1473 PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
1474 (unsigned long)sv, SvNVX(sv));
1475 RESTORE_NUMERIC_LOCAL();
1482 S_asIV(pTHX_ SV *sv)
1484 I32 numtype = looks_like_number(sv);
1487 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1488 return atol(SvPVX(sv)); /* XXXX 64-bit? */
1491 if (ckWARN(WARN_NUMERIC))
1494 d = Atof(SvPVX(sv));
1499 S_asUV(pTHX_ SV *sv)
1501 I32 numtype = looks_like_number(sv);
1504 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1505 return strtoul(SvPVX(sv), Null(char**), 10);
1509 if (ckWARN(WARN_NUMERIC))
1512 return U_V(Atof(SvPVX(sv)));
1516 * Returns a combination of (advisory only - can get false negatives)
1517 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1519 * 0 if does not look like number.
1521 * In fact possible values are 0 and
1522 * IS_NUMBER_TO_INT_BY_ATOL 123
1523 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1524 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1525 * with a possible addition of IS_NUMBER_NEG.
1529 Perl_looks_like_number(pTHX_ SV *sv)
1531 /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
1532 * using atof() may lose precision. */
1534 register char *send;
1535 register char *sbegin;
1536 register char *nbegin;
1544 else if (SvPOKp(sv))
1545 sbegin = SvPV(sv, len);
1548 send = sbegin + len;
1555 numtype = IS_NUMBER_NEG;
1562 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1563 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1567 /* next must be digit or the radix separator */
1571 } while (isDIGIT(*s));
1573 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1574 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1576 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1579 #ifdef USE_LOCALE_NUMERIC
1580 || IS_NUMERIC_RADIX(*s)
1584 numtype |= IS_NUMBER_NOT_IV;
1585 while (isDIGIT(*s)) /* optional digits after the radix */
1590 #ifdef USE_LOCALE_NUMERIC
1591 || IS_NUMERIC_RADIX(*s)
1595 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1596 /* no digits before the radix means we need digits after it */
1600 } while (isDIGIT(*s));
1608 /* we can have an optional exponent part */
1609 if (*s == 'e' || *s == 'E') {
1610 numtype &= ~IS_NUMBER_NEG;
1611 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1613 if (*s == '+' || *s == '-')
1618 } while (isDIGIT(*s));
1627 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1628 return IS_NUMBER_TO_INT_BY_ATOL;
1633 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1636 return sv_2pv(sv, &n_a);
1639 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1641 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1644 char *ptr = buf + TYPE_CHARS(UV);
1659 *--ptr = '0' + (uv % 10);
1668 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1673 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1674 char *tmpbuf = tbuf;
1680 if (SvGMAGICAL(sv)) {
1686 if (SvIOKp(sv)) { /* XXXX 64-bit? */
1688 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1690 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1695 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1700 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1702 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1703 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1709 if (SvTHINKFIRST(sv)) {
1712 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1713 return SvPV(tmpstr,*lp);
1720 switch (SvTYPE(sv)) {
1722 if ( ((SvFLAGS(sv) &
1723 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1724 == (SVs_OBJECT|SVs_RMG))
1725 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1726 && (mg = mg_find(sv, 'r'))) {
1728 regexp *re = (regexp *)mg->mg_obj;
1731 char *fptr = "msix";
1736 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1738 while(ch = *fptr++) {
1740 reflags[left++] = ch;
1743 reflags[right--] = ch;
1748 reflags[left] = '-';
1752 mg->mg_len = re->prelen + 4 + left;
1753 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1754 Copy("(?", mg->mg_ptr, 2, char);
1755 Copy(reflags, mg->mg_ptr+2, left, char);
1756 Copy(":", mg->mg_ptr+left+2, 1, char);
1757 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1758 mg->mg_ptr[mg->mg_len - 1] = ')';
1759 mg->mg_ptr[mg->mg_len] = 0;
1761 PL_reginterp_cnt += re->program[0].next_off;
1773 case SVt_PVBM: s = "SCALAR"; break;
1774 case SVt_PVLV: s = "LVALUE"; break;
1775 case SVt_PVAV: s = "ARRAY"; break;
1776 case SVt_PVHV: s = "HASH"; break;
1777 case SVt_PVCV: s = "CODE"; break;
1778 case SVt_PVGV: s = "GLOB"; break;
1779 case SVt_PVFM: s = "FORMAT"; break;
1780 case SVt_PVIO: s = "IO"; break;
1781 default: s = "UNKNOWN"; break;
1785 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1789 Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
1795 if (SvREADONLY(sv) && !SvOK(sv)) {
1797 if (ckWARN(WARN_UNINITIALIZED))
1798 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1803 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1804 /* XXXX 64-bit? IV may have better precision... */
1805 if (SvTYPE(sv) < SVt_PVNV)
1806 sv_upgrade(sv, SVt_PVNV);
1809 olderrno = errno; /* some Xenix systems wipe out errno here */
1811 if (SvNVX(sv) == 0.0)
1812 (void)strcpy(s,"0");
1816 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1819 #ifdef FIXNEGATIVEZERO
1820 if (*s == '-' && s[1] == '0' && !s[2])
1829 else if (SvIOKp(sv)) {
1830 U32 isIOK = SvIOK(sv);
1831 U32 isUIOK = SvIsUV(sv);
1832 char buf[TYPE_CHARS(UV)];
1835 if (SvTYPE(sv) < SVt_PVIV)
1836 sv_upgrade(sv, SVt_PVIV);
1838 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1840 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1841 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
1842 Move(ptr,SvPVX(sv),ebuf - ptr,char);
1843 SvCUR_set(sv, ebuf - ptr);
1856 if (ckWARN(WARN_UNINITIALIZED)
1857 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1859 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1862 if (SvTYPE(sv) < SVt_PV)
1863 /* Typically the caller expects that sv_any is not NULL now. */
1864 sv_upgrade(sv, SVt_PV);
1867 *lp = s - SvPVX(sv);
1870 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
1871 (unsigned long)sv,SvPVX(sv)));
1875 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1876 /* Sneaky stuff here */
1880 tsv = newSVpv(tmpbuf, 0);
1896 len = strlen(tmpbuf);
1898 #ifdef FIXNEGATIVEZERO
1899 if (len == 2 && t[0] == '-' && t[1] == '0') {
1904 (void)SvUPGRADE(sv, SVt_PV);
1906 s = SvGROW(sv, len + 1);
1914 /* This function is only called on magical items */
1916 Perl_sv_2bool(pTHX_ register SV *sv)
1926 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1927 return SvTRUE(tmpsv);
1928 return SvRV(sv) != 0;
1931 register XPV* Xpvtmp;
1932 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1933 (*Xpvtmp->xpv_pv > '0' ||
1934 Xpvtmp->xpv_cur > 1 ||
1935 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
1942 return SvIVX(sv) != 0;
1945 return SvNVX(sv) != 0.0;
1952 /* Note: sv_setsv() should not be called with a source string that needs
1953 * to be reused, since it may destroy the source string if it is marked
1958 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
1961 register U32 sflags;
1967 SV_CHECK_THINKFIRST(dstr);
1969 sstr = &PL_sv_undef;
1970 stype = SvTYPE(sstr);
1971 dtype = SvTYPE(dstr);
1975 /* There's a lot of redundancy below but we're going for speed here */
1980 if (dtype != SVt_PVGV) {
1981 (void)SvOK_off(dstr);
1989 sv_upgrade(dstr, SVt_IV);
1992 sv_upgrade(dstr, SVt_PVNV);
1996 sv_upgrade(dstr, SVt_PVIV);
1999 (void)SvIOK_only(dstr);
2000 SvIVX(dstr) = SvIVX(sstr);
2013 sv_upgrade(dstr, SVt_NV);
2018 sv_upgrade(dstr, SVt_PVNV);
2021 SvNVX(dstr) = SvNVX(sstr);
2022 (void)SvNOK_only(dstr);
2030 sv_upgrade(dstr, SVt_RV);
2031 else if (dtype == SVt_PVGV &&
2032 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2035 if (PL_curcop->cop_stash != GvSTASH(dstr))
2036 GvIMPORTED_on(dstr);
2046 sv_upgrade(dstr, SVt_PV);
2049 if (dtype < SVt_PVIV)
2050 sv_upgrade(dstr, SVt_PVIV);
2053 if (dtype < SVt_PVNV)
2054 sv_upgrade(dstr, SVt_PVNV);
2061 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2062 PL_op_name[PL_op->op_type]);
2064 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2068 if (dtype <= SVt_PVGV) {
2070 if (dtype != SVt_PVGV) {
2071 char *name = GvNAME(sstr);
2072 STRLEN len = GvNAMELEN(sstr);
2073 sv_upgrade(dstr, SVt_PVGV);
2074 sv_magic(dstr, dstr, '*', name, len);
2075 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2076 GvNAME(dstr) = savepvn(name, len);
2077 GvNAMELEN(dstr) = len;
2078 SvFAKE_on(dstr); /* can coerce to non-glob */
2080 /* ahem, death to those who redefine active sort subs */
2081 else if (PL_curstackinfo->si_type == PERLSI_SORT
2082 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2083 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2085 (void)SvOK_off(dstr);
2086 GvINTRO_off(dstr); /* one-shot flag */
2088 GvGP(dstr) = gp_ref(GvGP(sstr));
2090 if (PL_curcop->cop_stash != GvSTASH(dstr))
2091 GvIMPORTED_on(dstr);
2098 if (SvGMAGICAL(sstr)) {
2100 if (SvTYPE(sstr) != stype) {
2101 stype = SvTYPE(sstr);
2102 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2106 if (stype == SVt_PVLV)
2107 (void)SvUPGRADE(dstr, SVt_PVNV);
2109 (void)SvUPGRADE(dstr, stype);
2112 sflags = SvFLAGS(sstr);
2114 if (sflags & SVf_ROK) {
2115 if (dtype >= SVt_PV) {
2116 if (dtype == SVt_PVGV) {
2117 SV *sref = SvREFCNT_inc(SvRV(sstr));
2119 int intro = GvINTRO(dstr);
2123 GvGP(dstr)->gp_refcnt--;
2124 GvINTRO_off(dstr); /* one-shot flag */
2125 Newz(602,gp, 1, GP);
2126 GvGP(dstr) = gp_ref(gp);
2127 GvSV(dstr) = NEWSV(72,0);
2128 GvLINE(dstr) = PL_curcop->cop_line;
2129 GvEGV(dstr) = (GV*)dstr;
2132 switch (SvTYPE(sref)) {
2135 SAVESPTR(GvAV(dstr));
2137 dref = (SV*)GvAV(dstr);
2138 GvAV(dstr) = (AV*)sref;
2139 if (PL_curcop->cop_stash != GvSTASH(dstr))
2140 GvIMPORTED_AV_on(dstr);
2144 SAVESPTR(GvHV(dstr));
2146 dref = (SV*)GvHV(dstr);
2147 GvHV(dstr) = (HV*)sref;
2148 if (PL_curcop->cop_stash != GvSTASH(dstr))
2149 GvIMPORTED_HV_on(dstr);
2153 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2154 SvREFCNT_dec(GvCV(dstr));
2155 GvCV(dstr) = Nullcv;
2156 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2157 PL_sub_generation++;
2159 SAVESPTR(GvCV(dstr));
2162 dref = (SV*)GvCV(dstr);
2163 if (GvCV(dstr) != (CV*)sref) {
2164 CV* cv = GvCV(dstr);
2166 if (!GvCVGEN((GV*)dstr) &&
2167 (CvROOT(cv) || CvXSUB(cv)))
2169 SV *const_sv = cv_const_sv(cv);
2170 bool const_changed = TRUE;
2172 const_changed = sv_cmp(const_sv,
2173 op_const_sv(CvSTART((CV*)sref),
2175 /* ahem, death to those who redefine
2176 * active sort subs */
2177 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2178 PL_sortcop == CvSTART(cv))
2180 "Can't redefine active sort subroutine %s",
2181 GvENAME((GV*)dstr));
2182 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2183 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2184 && HvNAME(GvSTASH(CvGV(cv)))
2185 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2187 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2188 "Constant subroutine %s redefined"
2189 : "Subroutine %s redefined",
2190 GvENAME((GV*)dstr));
2193 cv_ckproto(cv, (GV*)dstr,
2194 SvPOK(sref) ? SvPVX(sref) : Nullch);
2196 GvCV(dstr) = (CV*)sref;
2197 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2198 GvASSUMECV_on(dstr);
2199 PL_sub_generation++;
2201 if (PL_curcop->cop_stash != GvSTASH(dstr))
2202 GvIMPORTED_CV_on(dstr);
2206 SAVESPTR(GvIOp(dstr));
2208 dref = (SV*)GvIOp(dstr);
2209 GvIOp(dstr) = (IO*)sref;
2213 SAVESPTR(GvSV(dstr));
2215 dref = (SV*)GvSV(dstr);
2217 if (PL_curcop->cop_stash != GvSTASH(dstr))
2218 GvIMPORTED_SV_on(dstr);
2229 (void)SvOOK_off(dstr); /* backoff */
2231 Safefree(SvPVX(dstr));
2232 SvLEN(dstr)=SvCUR(dstr)=0;
2235 (void)SvOK_off(dstr);
2236 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2238 if (sflags & SVp_NOK) {
2240 SvNVX(dstr) = SvNVX(sstr);
2242 if (sflags & SVp_IOK) {
2243 (void)SvIOK_on(dstr);
2244 SvIVX(dstr) = SvIVX(sstr);
2248 if (SvAMAGIC(sstr)) {
2252 else if (sflags & SVp_POK) {
2255 * Check to see if we can just swipe the string. If so, it's a
2256 * possible small lose on short strings, but a big win on long ones.
2257 * It might even be a win on short strings if SvPVX(dstr)
2258 * has to be allocated and SvPVX(sstr) has to be freed.
2261 if (SvTEMP(sstr) && /* slated for free anyway? */
2262 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2263 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2265 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2267 SvFLAGS(dstr) &= ~SVf_OOK;
2268 Safefree(SvPVX(dstr) - SvIVX(dstr));
2270 else if (SvLEN(dstr))
2271 Safefree(SvPVX(dstr));
2273 (void)SvPOK_only(dstr);
2274 SvPV_set(dstr, SvPVX(sstr));
2275 SvLEN_set(dstr, SvLEN(sstr));
2276 SvCUR_set(dstr, SvCUR(sstr));
2278 (void)SvOK_off(sstr);
2279 SvPV_set(sstr, Nullch);
2284 else { /* have to copy actual string */
2285 STRLEN len = SvCUR(sstr);
2287 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2288 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2289 SvCUR_set(dstr, len);
2290 *SvEND(dstr) = '\0';
2291 (void)SvPOK_only(dstr);
2294 if (sflags & SVp_NOK) {
2296 SvNVX(dstr) = SvNVX(sstr);
2298 if (sflags & SVp_IOK) {
2299 (void)SvIOK_on(dstr);
2300 SvIVX(dstr) = SvIVX(sstr);
2305 else if (sflags & SVp_NOK) {
2306 SvNVX(dstr) = SvNVX(sstr);
2307 (void)SvNOK_only(dstr);
2309 (void)SvIOK_on(dstr);
2310 SvIVX(dstr) = SvIVX(sstr);
2311 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2316 else if (sflags & SVp_IOK) {
2317 (void)SvIOK_only(dstr);
2318 SvIVX(dstr) = SvIVX(sstr);
2323 if (dtype == SVt_PVGV) {
2324 if (ckWARN(WARN_UNSAFE))
2325 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2328 (void)SvOK_off(dstr);
2334 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2336 sv_setsv(dstr,sstr);
2341 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2343 register char *dptr;
2344 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2345 elicit a warning, but it won't hurt. */
2346 SV_CHECK_THINKFIRST(sv);
2351 (void)SvUPGRADE(sv, SVt_PV);
2353 SvGROW(sv, len + 1);
2355 Move(ptr,dptr,len,char);
2358 (void)SvPOK_only(sv); /* validate pointer */
2363 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2365 sv_setpvn(sv,ptr,len);
2370 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2372 register STRLEN len;
2374 SV_CHECK_THINKFIRST(sv);
2380 (void)SvUPGRADE(sv, SVt_PV);
2382 SvGROW(sv, len + 1);
2383 Move(ptr,SvPVX(sv),len+1,char);
2385 (void)SvPOK_only(sv); /* validate pointer */
2390 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2397 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2399 SV_CHECK_THINKFIRST(sv);
2400 (void)SvUPGRADE(sv, SVt_PV);
2405 (void)SvOOK_off(sv);
2406 if (SvPVX(sv) && SvLEN(sv))
2407 Safefree(SvPVX(sv));
2408 Renew(ptr, len+1, char);
2411 SvLEN_set(sv, len+1);
2413 (void)SvPOK_only(sv); /* validate pointer */
2418 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2420 sv_usepvn(sv,ptr,len);
2425 Perl_sv_force_normal(pTHX_ register SV *sv)
2427 if (SvREADONLY(sv)) {
2429 if (PL_curcop != &PL_compiling)
2430 Perl_croak(aTHX_ PL_no_modify);
2434 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2439 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2443 register STRLEN delta;
2445 if (!ptr || !SvPOKp(sv))
2447 SV_CHECK_THINKFIRST(sv);
2448 if (SvTYPE(sv) < SVt_PVIV)
2449 sv_upgrade(sv,SVt_PVIV);
2452 if (!SvLEN(sv)) { /* make copy of shared string */
2453 char *pvx = SvPVX(sv);
2454 STRLEN len = SvCUR(sv);
2455 SvGROW(sv, len + 1);
2456 Move(pvx,SvPVX(sv),len,char);
2460 SvFLAGS(sv) |= SVf_OOK;
2462 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2463 delta = ptr - SvPVX(sv);
2471 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2476 junk = SvPV_force(sv, tlen);
2477 SvGROW(sv, tlen + len + 1);
2480 Move(ptr,SvPVX(sv)+tlen,len,char);
2483 (void)SvPOK_only(sv); /* validate pointer */
2488 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2490 sv_catpvn(sv,ptr,len);
2495 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2501 if (s = SvPV(sstr, len))
2502 sv_catpvn(dstr,s,len);
2506 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2508 sv_catsv(dstr,sstr);
2513 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2515 register STRLEN len;
2521 junk = SvPV_force(sv, tlen);
2523 SvGROW(sv, tlen + len + 1);
2526 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2528 (void)SvPOK_only(sv); /* validate pointer */
2533 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2540 Perl_newSV(pTHX_ STRLEN len)
2546 sv_upgrade(sv, SVt_PV);
2547 SvGROW(sv, len + 1);
2552 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2555 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2559 if (SvREADONLY(sv)) {
2561 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2562 Perl_croak(aTHX_ PL_no_modify);
2564 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2565 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2572 (void)SvUPGRADE(sv, SVt_PVMG);
2574 Newz(702,mg, 1, MAGIC);
2575 mg->mg_moremagic = SvMAGIC(sv);
2578 if (!obj || obj == sv || how == '#' || how == 'r')
2582 mg->mg_obj = SvREFCNT_inc(obj);
2583 mg->mg_flags |= MGf_REFCOUNTED;
2586 mg->mg_len = namlen;
2589 mg->mg_ptr = savepvn(name, namlen);
2590 else if (namlen == HEf_SVKEY)
2591 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2595 mg->mg_virtual = &PL_vtbl_sv;
2598 mg->mg_virtual = &PL_vtbl_amagic;
2601 mg->mg_virtual = &PL_vtbl_amagicelem;
2607 mg->mg_virtual = &PL_vtbl_bm;
2610 mg->mg_virtual = &PL_vtbl_regdata;
2613 mg->mg_virtual = &PL_vtbl_regdatum;
2616 mg->mg_virtual = &PL_vtbl_env;
2619 mg->mg_virtual = &PL_vtbl_fm;
2622 mg->mg_virtual = &PL_vtbl_envelem;
2625 mg->mg_virtual = &PL_vtbl_mglob;
2628 mg->mg_virtual = &PL_vtbl_isa;
2631 mg->mg_virtual = &PL_vtbl_isaelem;
2634 mg->mg_virtual = &PL_vtbl_nkeys;
2641 mg->mg_virtual = &PL_vtbl_dbline;
2645 mg->mg_virtual = &PL_vtbl_mutex;
2647 #endif /* USE_THREADS */
2648 #ifdef USE_LOCALE_COLLATE
2650 mg->mg_virtual = &PL_vtbl_collxfrm;
2652 #endif /* USE_LOCALE_COLLATE */
2654 mg->mg_virtual = &PL_vtbl_pack;
2658 mg->mg_virtual = &PL_vtbl_packelem;
2661 mg->mg_virtual = &PL_vtbl_regexp;
2664 mg->mg_virtual = &PL_vtbl_sig;
2667 mg->mg_virtual = &PL_vtbl_sigelem;
2670 mg->mg_virtual = &PL_vtbl_taint;
2674 mg->mg_virtual = &PL_vtbl_uvar;
2677 mg->mg_virtual = &PL_vtbl_vec;
2680 mg->mg_virtual = &PL_vtbl_substr;
2683 mg->mg_virtual = &PL_vtbl_defelem;
2686 mg->mg_virtual = &PL_vtbl_glob;
2689 mg->mg_virtual = &PL_vtbl_arylen;
2692 mg->mg_virtual = &PL_vtbl_pos;
2695 mg->mg_virtual = &PL_vtbl_backref;
2697 case '~': /* Reserved for use by extensions not perl internals. */
2698 /* Useful for attaching extension internal data to perl vars. */
2699 /* Note that multiple extensions may clash if magical scalars */
2700 /* etc holding private data from one are passed to another. */
2704 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
2708 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2712 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2716 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2719 for (mg = *mgp; mg; mg = *mgp) {
2720 if (mg->mg_type == type) {
2721 MGVTBL* vtbl = mg->mg_virtual;
2722 *mgp = mg->mg_moremagic;
2723 if (vtbl && (vtbl->svt_free != NULL))
2724 (VTBL->svt_free)(aTHX_ sv, mg);
2725 if (mg->mg_ptr && mg->mg_type != 'g')
2726 if (mg->mg_len >= 0)
2727 Safefree(mg->mg_ptr);
2728 else if (mg->mg_len == HEf_SVKEY)
2729 SvREFCNT_dec((SV*)mg->mg_ptr);
2730 if (mg->mg_flags & MGf_REFCOUNTED)
2731 SvREFCNT_dec(mg->mg_obj);
2735 mgp = &mg->mg_moremagic;
2739 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2746 Perl_sv_rvweaken(pTHX_ SV *sv)
2749 if (!SvOK(sv)) /* let undefs pass */
2752 Perl_croak(aTHX_ "Can't weaken a nonreference");
2753 else if (SvWEAKREF(sv)) {
2755 if (ckWARN(WARN_MISC))
2756 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
2760 sv_add_backref(tsv, sv);
2767 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
2771 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2772 av = (AV*)mg->mg_obj;
2775 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2776 SvREFCNT_dec(av); /* for sv_magic */
2782 S_sv_del_backref(pTHX_ SV *sv)
2789 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2790 Perl_croak(aTHX_ "panic: del_backref");
2791 av = (AV *)mg->mg_obj;
2796 svp[i] = &PL_sv_undef; /* XXX */
2803 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2807 register char *midend;
2808 register char *bigend;
2814 Perl_croak(aTHX_ "Can't modify non-existent substring");
2815 SvPV_force(bigstr, curlen);
2816 if (offset + len > curlen) {
2817 SvGROW(bigstr, offset+len+1);
2818 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2819 SvCUR_set(bigstr, offset+len);
2822 i = littlelen - len;
2823 if (i > 0) { /* string might grow */
2824 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2825 mid = big + offset + len;
2826 midend = bigend = big + SvCUR(bigstr);
2829 while (midend > mid) /* shove everything down */
2830 *--bigend = *--midend;
2831 Move(little,big+offset,littlelen,char);
2837 Move(little,SvPVX(bigstr)+offset,len,char);
2842 big = SvPVX(bigstr);
2845 bigend = big + SvCUR(bigstr);
2847 if (midend > bigend)
2848 Perl_croak(aTHX_ "panic: sv_insert");
2850 if (mid - big > bigend - midend) { /* faster to shorten from end */
2852 Move(little, mid, littlelen,char);
2855 i = bigend - midend;
2857 Move(midend, mid, i,char);
2861 SvCUR_set(bigstr, mid - big);
2864 else if (i = mid - big) { /* faster from front */
2865 midend -= littlelen;
2867 sv_chop(bigstr,midend-i);
2872 Move(little, mid, littlelen,char);
2874 else if (littlelen) {
2875 midend -= littlelen;
2876 sv_chop(bigstr,midend);
2877 Move(little,midend,littlelen,char);
2880 sv_chop(bigstr,midend);
2885 /* make sv point to what nstr did */
2888 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2891 U32 refcnt = SvREFCNT(sv);
2892 SV_CHECK_THINKFIRST(sv);
2893 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
2894 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
2895 if (SvMAGICAL(sv)) {
2899 sv_upgrade(nsv, SVt_PVMG);
2900 SvMAGIC(nsv) = SvMAGIC(sv);
2901 SvFLAGS(nsv) |= SvMAGICAL(sv);
2907 assert(!SvREFCNT(sv));
2908 StructCopy(nsv,sv,SV);
2909 SvREFCNT(sv) = refcnt;
2910 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2915 Perl_sv_clear(pTHX_ register SV *sv)
2919 assert(SvREFCNT(sv) == 0);
2923 if (PL_defstash) { /* Still have a symbol table? */
2928 Zero(&tmpref, 1, SV);
2929 sv_upgrade(&tmpref, SVt_RV);
2931 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
2932 SvREFCNT(&tmpref) = 1;
2935 stash = SvSTASH(sv);
2936 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2939 PUSHSTACKi(PERLSI_DESTROY);
2940 SvRV(&tmpref) = SvREFCNT_inc(sv);
2945 call_sv((SV*)GvCV(destructor),
2946 G_DISCARD|G_EVAL|G_KEEPERR);
2952 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
2954 del_XRV(SvANY(&tmpref));
2957 if (PL_in_clean_objs)
2958 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
2960 /* DESTROY gave object new lease on life */
2966 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
2967 SvOBJECT_off(sv); /* Curse the object. */
2968 if (SvTYPE(sv) != SVt_PVIO)
2969 --PL_sv_objcount; /* XXX Might want something more general */
2972 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
2975 switch (SvTYPE(sv)) {
2978 IoIFP(sv) != PerlIO_stdin() &&
2979 IoIFP(sv) != PerlIO_stdout() &&
2980 IoIFP(sv) != PerlIO_stderr())
2982 io_close((IO*)sv, FALSE);
2985 PerlDir_close(IoDIRP(sv));
2988 Safefree(IoTOP_NAME(sv));
2989 Safefree(IoFMT_NAME(sv));
2990 Safefree(IoBOTTOM_NAME(sv));
3005 SvREFCNT_dec(LvTARG(sv));
3009 Safefree(GvNAME(sv));
3010 /* cannot decrease stash refcount yet, as we might recursively delete
3011 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3012 of stash until current sv is completely gone.
3013 -- JohnPC, 27 Mar 1998 */
3014 stash = GvSTASH(sv);
3020 (void)SvOOK_off(sv);
3028 SvREFCNT_dec(SvRV(sv));
3030 else if (SvPVX(sv) && SvLEN(sv))
3031 Safefree(SvPVX(sv));
3041 switch (SvTYPE(sv)) {
3057 del_XPVIV(SvANY(sv));
3060 del_XPVNV(SvANY(sv));
3063 del_XPVMG(SvANY(sv));
3066 del_XPVLV(SvANY(sv));
3069 del_XPVAV(SvANY(sv));
3072 del_XPVHV(SvANY(sv));
3075 del_XPVCV(SvANY(sv));
3078 del_XPVGV(SvANY(sv));
3079 /* code duplication for increased performance. */
3080 SvFLAGS(sv) &= SVf_BREAK;
3081 SvFLAGS(sv) |= SVTYPEMASK;
3082 /* decrease refcount of the stash that owns this GV, if any */
3084 SvREFCNT_dec(stash);
3085 return; /* not break, SvFLAGS reset already happened */
3087 del_XPVBM(SvANY(sv));
3090 del_XPVFM(SvANY(sv));
3093 del_XPVIO(SvANY(sv));
3096 SvFLAGS(sv) &= SVf_BREAK;
3097 SvFLAGS(sv) |= SVTYPEMASK;
3101 Perl_sv_newref(pTHX_ SV *sv)
3104 ATOMIC_INC(SvREFCNT(sv));
3109 Perl_sv_free(pTHX_ SV *sv)
3112 int refcount_is_zero;
3116 if (SvREFCNT(sv) == 0) {
3117 if (SvFLAGS(sv) & SVf_BREAK)
3119 if (PL_in_clean_all) /* All is fair */
3121 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3122 /* make sure SvREFCNT(sv)==0 happens very seldom */
3123 SvREFCNT(sv) = (~(U32)0)/2;
3126 if (ckWARN_d(WARN_INTERNAL))
3127 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3130 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3131 if (!refcount_is_zero)
3135 if (ckWARN_d(WARN_DEBUGGING))
3136 Perl_warner(aTHX_ WARN_DEBUGGING,
3137 "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3141 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3142 /* make sure SvREFCNT(sv)==0 happens very seldom */
3143 SvREFCNT(sv) = (~(U32)0)/2;
3152 Perl_sv_len(pTHX_ register SV *sv)
3161 len = mg_length(sv);
3163 junk = SvPV(sv, len);
3168 Perl_sv_len_utf8(pTHX_ register SV *sv)
3179 len = mg_length(sv);
3182 s = (U8*)SvPV(sv, len);
3193 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3198 I32 uoffset = *offsetp;
3204 start = s = (U8*)SvPV(sv, len);
3206 while (s < send && uoffset--)
3210 *offsetp = s - start;
3214 while (s < send && ulen--)
3224 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3233 s = (U8*)SvPV(sv, len);
3235 Perl_croak(aTHX_ "panic: bad byte offset");
3236 send = s + *offsetp;
3244 if (ckWARN_d(WARN_UTF8))
3245 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3253 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3265 pv1 = SvPV(str1, cur1);
3270 pv2 = SvPV(str2, cur2);
3275 return memEQ(pv1, pv2, cur1);
3279 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3282 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3284 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3288 return cur2 ? -1 : 0;
3293 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3296 return retval < 0 ? -1 : 1;
3301 return cur1 < cur2 ? -1 : 1;
3305 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3307 #ifdef USE_LOCALE_COLLATE
3313 if (PL_collation_standard)
3317 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3319 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3321 if (!pv1 || !len1) {
3332 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3335 return retval < 0 ? -1 : 1;
3338 * When the result of collation is equality, that doesn't mean
3339 * that there are no differences -- some locales exclude some
3340 * characters from consideration. So to avoid false equalities,
3341 * we use the raw string as a tiebreaker.
3347 #endif /* USE_LOCALE_COLLATE */
3349 return sv_cmp(sv1, sv2);
3352 #ifdef USE_LOCALE_COLLATE
3354 * Any scalar variable may carry an 'o' magic that contains the
3355 * scalar data of the variable transformed to such a format that
3356 * a normal memory comparison can be used to compare the data
3357 * according to the locale settings.
3360 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3364 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3365 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3370 Safefree(mg->mg_ptr);
3372 if ((xf = mem_collxfrm(s, len, &xlen))) {
3373 if (SvREADONLY(sv)) {
3376 return xf + sizeof(PL_collation_ix);
3379 sv_magic(sv, 0, 'o', 0, 0);
3380 mg = mg_find(sv, 'o');
3393 if (mg && mg->mg_ptr) {
3395 return mg->mg_ptr + sizeof(PL_collation_ix);
3403 #endif /* USE_LOCALE_COLLATE */
3406 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3411 register STDCHAR rslast;
3412 register STDCHAR *bp;
3416 SV_CHECK_THINKFIRST(sv);
3417 (void)SvUPGRADE(sv, SVt_PV);
3421 if (RsSNARF(PL_rs)) {
3425 else if (RsRECORD(PL_rs)) {
3426 I32 recsize, bytesread;
3429 /* Grab the size of the record we're getting */
3430 recsize = SvIV(SvRV(PL_rs));
3431 (void)SvPOK_only(sv); /* Validate pointer */
3432 buffer = SvGROW(sv, recsize + 1);
3435 /* VMS wants read instead of fread, because fread doesn't respect */
3436 /* RMS record boundaries. This is not necessarily a good thing to be */
3437 /* doing, but we've got no other real choice */
3438 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3440 bytesread = PerlIO_read(fp, buffer, recsize);
3442 SvCUR_set(sv, bytesread);
3443 buffer[bytesread] = '\0';
3444 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3446 else if (RsPARA(PL_rs)) {
3451 rsptr = SvPV(PL_rs, rslen);
3452 rslast = rslen ? rsptr[rslen - 1] : '\0';
3454 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3455 do { /* to make sure file boundaries work right */
3458 i = PerlIO_getc(fp);
3462 PerlIO_ungetc(fp,i);
3468 /* See if we know enough about I/O mechanism to cheat it ! */
3470 /* This used to be #ifdef test - it is made run-time test for ease
3471 of abstracting out stdio interface. One call should be cheap
3472 enough here - and may even be a macro allowing compile
3476 if (PerlIO_fast_gets(fp)) {
3479 * We're going to steal some values from the stdio struct
3480 * and put EVERYTHING in the innermost loop into registers.
3482 register STDCHAR *ptr;
3486 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3487 /* An ungetc()d char is handled separately from the regular
3488 * buffer, so we getc() it back out and stuff it in the buffer.
3490 i = PerlIO_getc(fp);
3491 if (i == EOF) return 0;
3492 *(--((*fp)->_ptr)) = (unsigned char) i;
3496 /* Here is some breathtakingly efficient cheating */
3498 cnt = PerlIO_get_cnt(fp); /* get count into register */
3499 (void)SvPOK_only(sv); /* validate pointer */
3500 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3501 if (cnt > 80 && SvLEN(sv) > append) {
3502 shortbuffered = cnt - SvLEN(sv) + append + 1;
3503 cnt -= shortbuffered;
3507 /* remember that cnt can be negative */
3508 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3513 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3514 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3515 DEBUG_P(PerlIO_printf(Perl_debug_log,
3516 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3517 DEBUG_P(PerlIO_printf(Perl_debug_log,
3518 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3519 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3520 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3525 while (cnt > 0) { /* this | eat */
3527 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3528 goto thats_all_folks; /* screams | sed :-) */
3532 Copy(ptr, bp, cnt, char); /* this | eat */
3533 bp += cnt; /* screams | dust */
3534 ptr += cnt; /* louder | sed :-) */
3539 if (shortbuffered) { /* oh well, must extend */
3540 cnt = shortbuffered;
3542 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3544 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3545 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3549 DEBUG_P(PerlIO_printf(Perl_debug_log,
3550 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3551 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3552 DEBUG_P(PerlIO_printf(Perl_debug_log,
3553 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3554 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3555 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3556 /* This used to call 'filbuf' in stdio form, but as that behaves like
3557 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3558 another abstraction. */
3559 i = PerlIO_getc(fp); /* get more characters */
3560 DEBUG_P(PerlIO_printf(Perl_debug_log,
3561 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3562 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3563 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3564 cnt = PerlIO_get_cnt(fp);
3565 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3566 DEBUG_P(PerlIO_printf(Perl_debug_log,
3567 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3569 if (i == EOF) /* all done for ever? */
3570 goto thats_really_all_folks;
3572 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3574 SvGROW(sv, bpx + cnt + 2);
3575 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3577 *bp++ = i; /* store character from PerlIO_getc */
3579 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3580 goto thats_all_folks;
3584 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3585 memNE((char*)bp - rslen, rsptr, rslen))
3586 goto screamer; /* go back to the fray */
3587 thats_really_all_folks:
3589 cnt += shortbuffered;
3590 DEBUG_P(PerlIO_printf(Perl_debug_log,
3591 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3592 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3593 DEBUG_P(PerlIO_printf(Perl_debug_log,
3594 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3595 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3596 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3598 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3599 DEBUG_P(PerlIO_printf(Perl_debug_log,
3600 "Screamer: done, len=%ld, string=|%.*s|\n",
3601 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3606 /*The big, slow, and stupid way */
3609 /* Need to work around EPOC SDK features */
3610 /* On WINS: MS VC5 generates calls to _chkstk, */
3611 /* if a `large' stack frame is allocated */
3612 /* gcc on MARM does not generate calls like these */
3618 register STDCHAR *bpe = buf + sizeof(buf);
3620 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3621 ; /* keep reading */
3625 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3626 /* Accomodate broken VAXC compiler, which applies U8 cast to
3627 * both args of ?: operator, causing EOF to change into 255
3629 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3633 sv_catpvn(sv, (char *) buf, cnt);
3635 sv_setpvn(sv, (char *) buf, cnt);
3637 if (i != EOF && /* joy */
3639 SvCUR(sv) < rslen ||
3640 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3644 * If we're reading from a TTY and we get a short read,
3645 * indicating that the user hit his EOF character, we need
3646 * to notice it now, because if we try to read from the TTY
3647 * again, the EOF condition will disappear.
3649 * The comparison of cnt to sizeof(buf) is an optimization
3650 * that prevents unnecessary calls to feof().
3654 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3659 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3660 while (i != EOF) { /* to make sure file boundaries work right */
3661 i = PerlIO_getc(fp);
3663 PerlIO_ungetc(fp,i);
3670 win32_strip_return(sv);
3673 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3678 Perl_sv_inc(pTHX_ register SV *sv)
3687 if (SvTHINKFIRST(sv)) {
3688 if (SvREADONLY(sv)) {
3690 if (PL_curcop != &PL_compiling)
3691 Perl_croak(aTHX_ PL_no_modify);
3695 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3702 flags = SvFLAGS(sv);
3703 if (flags & SVp_NOK) {
3704 (void)SvNOK_only(sv);
3708 if (flags & SVp_IOK) {
3710 if (SvUVX(sv) == UV_MAX)
3711 sv_setnv(sv, (NV)UV_MAX + 1.0);
3713 (void)SvIOK_only_UV(sv);
3716 if (SvIVX(sv) == IV_MAX)
3717 sv_setnv(sv, (NV)IV_MAX + 1.0);
3719 (void)SvIOK_only(sv);
3725 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3726 if ((flags & SVTYPEMASK) < SVt_PVNV)
3727 sv_upgrade(sv, SVt_NV);
3729 (void)SvNOK_only(sv);
3733 while (isALPHA(*d)) d++;
3734 while (isDIGIT(*d)) d++;
3736 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
3740 while (d >= SvPVX(sv)) {
3748 /* MKS: The original code here died if letters weren't consecutive.
3749 * at least it didn't have to worry about non-C locales. The
3750 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3751 * arranged in order (although not consecutively) and that only
3752 * [A-Za-z] are accepted by isALPHA in the C locale.
3754 if (*d != 'z' && *d != 'Z') {
3755 do { ++*d; } while (!isALPHA(*d));
3758 *(d--) -= 'z' - 'a';
3763 *(d--) -= 'z' - 'a' + 1;
3767 /* oh,oh, the number grew */
3768 SvGROW(sv, SvCUR(sv) + 2);
3770 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3779 Perl_sv_dec(pTHX_ register SV *sv)
3787 if (SvTHINKFIRST(sv)) {
3788 if (SvREADONLY(sv)) {
3790 if (PL_curcop != &PL_compiling)
3791 Perl_croak(aTHX_ PL_no_modify);
3795 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3802 flags = SvFLAGS(sv);
3803 if (flags & SVp_NOK) {
3805 (void)SvNOK_only(sv);
3808 if (flags & SVp_IOK) {
3810 if (SvUVX(sv) == 0) {
3811 (void)SvIOK_only(sv);
3815 (void)SvIOK_only_UV(sv);
3819 if (SvIVX(sv) == IV_MIN)
3820 sv_setnv(sv, (NV)IV_MIN - 1.0);
3822 (void)SvIOK_only(sv);
3828 if (!(flags & SVp_POK)) {
3829 if ((flags & SVTYPEMASK) < SVt_PVNV)
3830 sv_upgrade(sv, SVt_NV);
3832 (void)SvNOK_only(sv);
3835 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
3838 /* Make a string that will exist for the duration of the expression
3839 * evaluation. Actually, it may have to last longer than that, but
3840 * hopefully we won't free it until it has been assigned to a
3841 * permanent location. */
3844 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3850 sv_setsv(sv,oldstr);
3852 PL_tmps_stack[++PL_tmps_ix] = sv;
3858 Perl_sv_newmortal(pTHX)
3864 SvFLAGS(sv) = SVs_TEMP;
3866 PL_tmps_stack[++PL_tmps_ix] = sv;
3870 /* same thing without the copying */
3873 Perl_sv_2mortal(pTHX_ register SV *sv)
3878 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3881 PL_tmps_stack[++PL_tmps_ix] = sv;
3887 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3894 sv_setpvn(sv,s,len);
3899 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3904 sv_setpvn(sv,s,len);
3908 #if defined(PERL_IMPLICIT_CONTEXT)
3910 Perl_newSVpvf_nocontext(const char* pat, ...)
3915 va_start(args, pat);
3916 sv = vnewSVpvf(pat, &args);
3923 Perl_newSVpvf(pTHX_ const char* pat, ...)
3927 va_start(args, pat);
3928 sv = vnewSVpvf(pat, &args);
3934 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
3938 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
3943 Perl_newSVnv(pTHX_ NV n)
3953 Perl_newSViv(pTHX_ IV i)
3963 Perl_newRV_noinc(pTHX_ SV *tmpRef)
3969 sv_upgrade(sv, SVt_RV);
3977 Perl_newRV(pTHX_ SV *tmpRef)
3979 return newRV_noinc(SvREFCNT_inc(tmpRef));
3982 /* make an exact duplicate of old */
3985 Perl_newSVsv(pTHX_ register SV *old)
3992 if (SvTYPE(old) == SVTYPEMASK) {
3993 if (ckWARN_d(WARN_INTERNAL))
3994 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4009 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4022 if (!*s) { /* reset ?? searches */
4023 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4024 pm->op_pmdynflags &= ~PMdf_USED;
4029 /* reset variables */
4031 if (!HvARRAY(stash))
4034 Zero(todo, 256, char);
4041 for ( ; i <= max; i++) {
4044 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4045 for (entry = HvARRAY(stash)[i];
4047 entry = HeNEXT(entry))
4049 if (!todo[(U8)*HeKEY(entry)])
4051 gv = (GV*)HeVAL(entry);
4053 if (SvTHINKFIRST(sv)) {
4054 if (!SvREADONLY(sv) && SvROK(sv))
4059 if (SvTYPE(sv) >= SVt_PV) {
4061 if (SvPVX(sv) != Nullch)
4068 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4070 #ifndef VMS /* VMS has no environ array */
4072 environ[0] = Nullch;
4081 Perl_sv_2io(pTHX_ SV *sv)
4087 switch (SvTYPE(sv)) {
4095 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4099 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4101 return sv_2io(SvRV(sv));
4102 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4108 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4115 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4122 return *gvp = Nullgv, Nullcv;
4123 switch (SvTYPE(sv)) {
4143 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4144 tryAMAGICunDEREF(to_cv);
4147 if (SvTYPE(sv) == SVt_PVCV) {
4156 Perl_croak(aTHX_ "Not a subroutine reference");
4161 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4167 if (lref && !GvCVu(gv)) {
4170 tmpsv = NEWSV(704,0);
4171 gv_efullname3(tmpsv, gv, Nullch);
4172 /* XXX this is probably not what they think they're getting.
4173 * It has the same effect as "sub name;", i.e. just a forward
4175 newSUB(start_subparse(FALSE, 0),
4176 newSVOP(OP_CONST, 0, tmpsv),
4181 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4188 Perl_sv_true(pTHX_ register SV *sv)
4195 if ((tXpv = (XPV*)SvANY(sv)) &&
4196 (*tXpv->xpv_pv > '0' ||
4197 tXpv->xpv_cur > 1 ||
4198 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4205 return SvIVX(sv) != 0;
4208 return SvNVX(sv) != 0.0;
4210 return sv_2bool(sv);
4216 Perl_sv_iv(pTHX_ register SV *sv)
4220 return (IV)SvUVX(sv);
4227 Perl_sv_uv(pTHX_ register SV *sv)
4232 return (UV)SvIVX(sv);
4238 Perl_sv_nv(pTHX_ register SV *sv)
4246 Perl_sv_pv(pTHX_ SV *sv)
4253 return sv_2pv(sv, &n_a);
4257 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4263 return sv_2pv(sv, lp);
4267 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4271 if (SvTHINKFIRST(sv) && !SvROK(sv))
4272 sv_force_normal(sv);
4278 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4280 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4281 PL_op_name[PL_op->op_type]);
4285 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4290 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4291 SvGROW(sv, len + 1);
4292 Move(s,SvPVX(sv),len,char);
4297 SvPOK_on(sv); /* validate pointer */
4299 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4300 (unsigned long)sv,SvPVX(sv)));
4307 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4309 if (ob && SvOBJECT(sv))
4310 return HvNAME(SvSTASH(sv));
4312 switch (SvTYPE(sv)) {
4326 case SVt_PVLV: return "LVALUE";
4327 case SVt_PVAV: return "ARRAY";
4328 case SVt_PVHV: return "HASH";
4329 case SVt_PVCV: return "CODE";
4330 case SVt_PVGV: return "GLOB";
4331 case SVt_PVFM: return "FORMAT";
4332 default: return "UNKNOWN";
4338 Perl_sv_isobject(pTHX_ SV *sv)
4353 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4365 return strEQ(HvNAME(SvSTASH(sv)), name);
4369 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4376 SV_CHECK_THINKFIRST(rv);
4379 if (SvTYPE(rv) < SVt_RV)
4380 sv_upgrade(rv, SVt_RV);
4387 HV* stash = gv_stashpv(classname, TRUE);
4388 (void)sv_bless(rv, stash);
4394 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4397 sv_setsv(rv, &PL_sv_undef);
4401 sv_setiv(newSVrv(rv,classname), (IV)pv);
4406 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4408 sv_setiv(newSVrv(rv,classname), iv);
4413 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4415 sv_setnv(newSVrv(rv,classname), nv);
4420 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4422 sv_setpvn(newSVrv(rv,classname), pv, n);
4427 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4432 Perl_croak(aTHX_ "Can't bless non-reference value");
4434 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4435 if (SvREADONLY(tmpRef))
4436 Perl_croak(aTHX_ PL_no_modify);
4437 if (SvOBJECT(tmpRef)) {
4438 if (SvTYPE(tmpRef) != SVt_PVIO)
4440 SvREFCNT_dec(SvSTASH(tmpRef));
4443 SvOBJECT_on(tmpRef);
4444 if (SvTYPE(tmpRef) != SVt_PVIO)
4446 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4447 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4458 S_sv_unglob(pTHX_ SV *sv)
4460 assert(SvTYPE(sv) == SVt_PVGV);
4465 SvREFCNT_dec(GvSTASH(sv));
4466 GvSTASH(sv) = Nullhv;
4468 sv_unmagic(sv, '*');
4469 Safefree(GvNAME(sv));
4471 SvFLAGS(sv) &= ~SVTYPEMASK;
4472 SvFLAGS(sv) |= SVt_PVMG;
4476 Perl_sv_unref(pTHX_ SV *sv)
4480 if (SvWEAKREF(sv)) {
4488 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4491 sv_2mortal(rv); /* Schedule for freeing later */
4495 Perl_sv_taint(pTHX_ SV *sv)
4497 sv_magic((sv), Nullsv, 't', Nullch, 0);
4501 Perl_sv_untaint(pTHX_ SV *sv)
4503 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4504 MAGIC *mg = mg_find(sv, 't');
4511 Perl_sv_tainted(pTHX_ SV *sv)
4513 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4514 MAGIC *mg = mg_find(sv, 't');
4515 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4522 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4524 char buf[TYPE_CHARS(UV)];
4526 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4528 sv_setpvn(sv, ptr, ebuf - ptr);
4533 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4535 char buf[TYPE_CHARS(UV)];
4537 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4539 sv_setpvn(sv, ptr, ebuf - ptr);
4543 #if defined(PERL_IMPLICIT_CONTEXT)
4545 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4549 va_start(args, pat);
4550 sv_vsetpvf(sv, pat, &args);
4556 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4560 va_start(args, pat);
4561 sv_vsetpvf_mg(sv, pat, &args);
4567 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4570 va_start(args, pat);
4571 sv_vsetpvf(sv, pat, &args);
4576 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4578 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4582 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4585 va_start(args, pat);
4586 sv_vsetpvf_mg(sv, pat, &args);
4591 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4593 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4597 #if defined(PERL_IMPLICIT_CONTEXT)
4599 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4603 va_start(args, pat);
4604 sv_vcatpvf(sv, pat, &args);
4609 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4613 va_start(args, pat);
4614 sv_vcatpvf_mg(sv, pat, &args);
4620 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4623 va_start(args, pat);
4624 sv_vcatpvf(sv, pat, &args);
4629 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4631 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4635 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4638 va_start(args, pat);
4639 sv_vcatpvf_mg(sv, pat, &args);
4644 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4646 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4651 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4653 sv_setpvn(sv, "", 0);
4654 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4658 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4666 static char nullstr[] = "(null)";
4668 /* no matter what, this is a string now */
4669 (void)SvPV_force(sv, origlen);
4671 /* special-case "", "%s", and "%_" */
4674 if (patlen == 2 && pat[0] == '%') {
4678 char *s = va_arg(*args, char*);
4679 sv_catpv(sv, s ? s : nullstr);
4681 else if (svix < svmax)
4682 sv_catsv(sv, *svargs);
4686 sv_catsv(sv, va_arg(*args, SV*));
4689 /* See comment on '_' below */
4694 patend = (char*)pat + patlen;
4695 for (p = (char*)pat; p < patend; p = q) {
4703 bool has_precis = FALSE;
4708 STRLEN esignlen = 0;
4710 char *eptr = Nullch;
4712 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4723 for (q = p; q < patend && *q != '%'; ++q) ;
4725 sv_catpvn(sv, p, q - p);
4763 case '1': case '2': case '3':
4764 case '4': case '5': case '6':
4765 case '7': case '8': case '9':
4768 width = width * 10 + (*q++ - '0');
4773 i = va_arg(*args, int);
4775 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4777 width = (i < 0) ? -i : i;
4788 i = va_arg(*args, int);
4790 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4791 precis = (i < 0) ? 0 : i;
4797 precis = precis * 10 + (*q++ - '0');
4806 #if 0 /* when quads have better support within Perl */
4807 if (*(q + 1) == 'l') {
4834 uv = va_arg(*args, int);
4836 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4838 eptr = (char*)utf8buf;
4839 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4843 c = va_arg(*args, int);
4845 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4852 eptr = va_arg(*args, char*);
4854 elen = strlen(eptr);
4857 elen = sizeof nullstr - 1;
4860 else if (svix < svmax) {
4861 eptr = SvPVx(svargs[svix++], elen);
4863 if (has_precis && precis < elen) {
4865 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4868 if (width) { /* fudge width (can't fudge elen) */
4869 width += elen - sv_len_utf8(svargs[svix - 1]);
4877 * The "%_" hack might have to be changed someday,
4878 * if ISO or ANSI decide to use '_' for something.
4879 * So we keep it hidden from users' code.
4883 eptr = SvPVx(va_arg(*args, SV*), elen);
4886 if (has_precis && elen > precis)
4894 uv = (UV)va_arg(*args, void*);
4896 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4907 case 'h': iv = (short)va_arg(*args, int); break;
4908 default: iv = va_arg(*args, int); break;
4909 case 'l': iv = va_arg(*args, long); break;
4910 case 'V': iv = va_arg(*args, IV); break;
4914 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4916 case 'h': iv = (short)iv; break;
4917 default: iv = (int)iv; break;
4918 case 'l': iv = (long)iv; break;
4925 esignbuf[esignlen++] = plus;
4929 esignbuf[esignlen++] = '-';
4959 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4960 default: uv = va_arg(*args, unsigned); break;
4961 case 'l': uv = va_arg(*args, unsigned long); break;
4962 case 'V': uv = va_arg(*args, UV); break;
4966 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4968 case 'h': uv = (unsigned short)uv; break;
4969 default: uv = (unsigned)uv; break;
4970 case 'l': uv = (unsigned long)uv; break;
4976 eptr = ebuf + sizeof ebuf;
4982 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
4988 esignbuf[esignlen++] = '0';
4989 esignbuf[esignlen++] = c; /* 'x' or 'X' */
4995 *--eptr = '0' + dig;
4997 if (alt && *eptr != '0')
5003 *--eptr = '0' + dig;
5005 if (alt && *eptr != '0')
5008 default: /* it had better be ten or less */
5011 *--eptr = '0' + dig;
5012 } while (uv /= base);
5015 elen = (ebuf + sizeof ebuf) - eptr;
5018 zeros = precis - elen;
5019 else if (precis == 0 && elen == 1 && *eptr == '0')
5024 /* FLOATING POINT */
5027 c = 'f'; /* maybe %F isn't supported here */
5033 /* This is evil, but floating point is even more evil */
5036 nv = va_arg(*args, NV);
5038 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5041 if (c != 'e' && c != 'E') {
5043 (void)frexp(nv, &i);
5044 if (i == PERL_INT_MIN)
5045 Perl_die(aTHX_ "panic: frexp");
5047 need = BIT_DIGITS(i);
5049 need += has_precis ? precis : 6; /* known default */
5053 need += 20; /* fudge factor */
5054 if (PL_efloatsize < need) {
5055 Safefree(PL_efloatbuf);
5056 PL_efloatsize = need + 20; /* more fudge */
5057 New(906, PL_efloatbuf, PL_efloatsize, char);
5060 eptr = ebuf + sizeof ebuf;
5063 #ifdef USE_LONG_DOUBLE
5068 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5073 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5086 RESTORE_NUMERIC_STANDARD();
5087 (void)sprintf(PL_efloatbuf, eptr, nv);
5088 RESTORE_NUMERIC_LOCAL();
5091 eptr = PL_efloatbuf;
5092 elen = strlen(PL_efloatbuf);
5096 * User-defined locales may include arbitrary characters.
5097 * And, unfortunately, some system may alloc the "C" locale
5098 * to be overridden by a malicious user.
5101 *used_locale = TRUE;
5102 #endif /* LC_NUMERIC */
5109 i = SvCUR(sv) - origlen;
5112 case 'h': *(va_arg(*args, short*)) = i; break;
5113 default: *(va_arg(*args, int*)) = i; break;
5114 case 'l': *(va_arg(*args, long*)) = i; break;
5115 case 'V': *(va_arg(*args, IV*)) = i; break;
5118 else if (svix < svmax)
5119 sv_setuv(svargs[svix++], (UV)i);
5120 continue; /* not "break" */
5126 if (!args && ckWARN(WARN_PRINTF) &&
5127 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5128 SV *msg = sv_newmortal();
5129 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5130 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5132 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5135 sv_catpv(msg, "end of string");
5136 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5139 /* output mangled stuff ... */
5145 /* ... right here, because formatting flags should not apply */
5146 SvGROW(sv, SvCUR(sv) + elen + 1);
5148 memcpy(p, eptr, elen);
5151 SvCUR(sv) = p - SvPVX(sv);
5152 continue; /* not "break" */
5155 have = esignlen + zeros + elen;
5156 need = (have > width ? have : width);
5159 SvGROW(sv, SvCUR(sv) + need + 1);
5161 if (esignlen && fill == '0') {
5162 for (i = 0; i < esignlen; i++)
5166 memset(p, fill, gap);
5169 if (esignlen && fill != '0') {
5170 for (i = 0; i < esignlen; i++)
5174 for (i = zeros; i; i--)
5178 memcpy(p, eptr, elen);
5182 memset(p, ' ', gap);
5186 SvCUR(sv) = p - SvPVX(sv);
5197 do_report_used(pTHXo_ SV *sv)
5199 if (SvTYPE(sv) != SVTYPEMASK) {
5200 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
5201 PerlIO_printf(PerlIO_stderr(), "****\n");
5207 do_clean_objs(pTHXo_ SV *sv)
5211 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5212 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
5218 /* XXX Might want to check arrays, etc. */
5221 #ifndef DISABLE_DESTRUCTOR_KLUDGE
5223 do_clean_named_objs(pTHXo_ SV *sv)
5225 if (SvTYPE(sv) == SVt_PVGV) {
5226 if ( SvOBJECT(GvSV(sv)) ||
5227 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
5228 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
5229 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
5230 GvCV(sv) && SvOBJECT(GvCV(sv)) )
5232 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
5240 do_clean_all(pTHXo_ SV *sv)
5242 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
5243 SvFLAGS(sv) |= SVf_BREAK;