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 VTBL this->*vtbl
20 #else /* !PERL_OBJECT */
22 #endif /* PERL_OBJECT */
25 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
27 static void do_report_used(pTHXo_ SV *sv);
28 static void do_clean_objs(pTHXo_ SV *sv);
29 #ifndef DISABLE_DESTRUCTOR_KLUDGE
30 static void do_clean_named_objs(pTHXo_ SV *sv);
32 static void do_clean_all(pTHXo_ SV *sv);
40 (p) = (SV*)safemalloc(sizeof(SV)); \
52 Safefree((char*)(p)); \
57 static I32 registry_size;
59 #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
61 #define REG_REPLACE(sv,a,b) \
63 void* p = sv->sv_any; \
64 I32 h = REGHASH(sv, registry_size); \
66 while (registry[i] != (a)) { \
67 if (++i >= registry_size) \
70 Perl_die(aTHX_ "SV registry bug"); \
75 #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
76 #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
79 S_reg_add(pTHX_ SV *sv)
81 if (PL_sv_count >= (registry_size >> 1))
83 SV **oldreg = registry;
84 I32 oldsize = registry_size;
86 registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
87 Newz(707, registry, registry_size, SV*);
92 for (i = 0; i < oldsize; ++i) {
93 SV* oldsv = oldreg[i];
106 S_reg_remove(pTHX_ SV *sv)
113 S_visit(pTHX_ SVFUNC_t f)
117 for (i = 0; i < registry_size; ++i) {
118 SV* sv = registry[i];
119 if (sv && SvTYPE(sv) != SVTYPEMASK)
125 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
127 if (!(flags & SVf_FAKE))
134 * "A time to plant, and a time to uproot what was planted..."
137 #define plant_SV(p) \
139 SvANY(p) = (void *)PL_sv_root; \
140 SvFLAGS(p) = SVTYPEMASK; \
145 /* sv_mutex must be held while calling uproot_SV() */
146 #define uproot_SV(p) \
149 PL_sv_root = (SV*)SvANY(p); \
171 if (PL_debug & 32768) \
179 S_del_sv(pTHX_ SV *p)
181 if (PL_debug & 32768) {
186 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
188 svend = &sva[SvREFCNT(sva)];
189 if (p >= sv && p < svend)
193 if (ckWARN_d(WARN_INTERNAL))
194 Perl_warner(aTHX_ WARN_INTERNAL,
195 "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
202 #else /* ! DEBUGGING */
204 #define del_SV(p) plant_SV(p)
206 #endif /* DEBUGGING */
209 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
214 Zero(sva, size, char);
216 /* The first SV in an arena isn't an SV. */
217 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
218 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
219 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
221 PL_sv_arenaroot = sva;
222 PL_sv_root = sva + 1;
224 svend = &sva[SvREFCNT(sva) - 1];
227 SvANY(sv) = (void *)(SV*)(sv + 1);
228 SvFLAGS(sv) = SVTYPEMASK;
232 SvFLAGS(sv) = SVTYPEMASK;
235 /* sv_mutex must be held while calling more_sv() */
242 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
243 PL_nice_chunk = Nullch;
246 char *chunk; /* must use New here to match call to */
247 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
248 sv_add_arena(chunk, 1008, 0);
255 S_visit(pTHX_ SVFUNC_t f)
261 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
262 svend = &sva[SvREFCNT(sva)];
263 for (sv = sva + 1; sv < svend; ++sv) {
264 if (SvTYPE(sv) != SVTYPEMASK)
273 Perl_sv_report_used(pTHX)
275 visit(do_report_used);
279 Perl_sv_clean_objs(pTHX)
281 PL_in_clean_objs = TRUE;
282 visit(do_clean_objs);
283 #ifndef DISABLE_DESTRUCTOR_KLUDGE
284 /* some barnacles may yet remain, clinging to typeglobs */
285 visit(do_clean_named_objs);
287 PL_in_clean_objs = FALSE;
291 Perl_sv_clean_all(pTHX)
293 PL_in_clean_all = TRUE;
295 PL_in_clean_all = FALSE;
299 Perl_sv_free_arenas(pTHX)
304 /* Free arenas here, but be careful about fake ones. (We assume
305 contiguity of the fake ones with the corresponding real ones.) */
307 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
308 svanext = (SV*) SvANY(sva);
309 while (svanext && SvFAKE(svanext))
310 svanext = (SV*) SvANY(svanext);
313 Safefree((void *)sva);
317 Safefree(PL_nice_chunk);
318 PL_nice_chunk = Nullch;
319 PL_nice_chunk_size = 0;
333 * See comment in more_xiv() -- RAM.
335 PL_xiv_root = *(IV**)xiv;
337 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
341 S_del_xiv(pTHX_ XPVIV *p)
343 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
345 *(IV**)xiv = PL_xiv_root;
356 New(705, ptr, 1008/sizeof(XPV), XPV);
357 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
358 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
361 xivend = &xiv[1008 / sizeof(IV) - 1];
362 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
364 while (xiv < xivend) {
365 *(IV**)xiv = (IV *)(xiv + 1);
379 PL_xnv_root = *(NV**)xnv;
381 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
385 S_del_xnv(pTHX_ XPVNV *p)
387 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
389 *(NV**)xnv = PL_xnv_root;
399 New(711, xnv, 1008/sizeof(NV), NV);
400 xnvend = &xnv[1008 / sizeof(NV) - 1];
401 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
403 while (xnv < xnvend) {
404 *(NV**)xnv = (NV*)(xnv + 1);
418 PL_xrv_root = (XRV*)xrv->xrv_rv;
424 S_del_xrv(pTHX_ XRV *p)
427 p->xrv_rv = (SV*)PL_xrv_root;
436 register XRV* xrvend;
437 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
439 xrvend = &xrv[1008 / sizeof(XRV) - 1];
440 while (xrv < xrvend) {
441 xrv->xrv_rv = (SV*)(xrv + 1);
455 PL_xpv_root = (XPV*)xpv->xpv_pv;
461 S_del_xpv(pTHX_ XPV *p)
464 p->xpv_pv = (char*)PL_xpv_root;
473 register XPV* xpvend;
474 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
476 xpvend = &xpv[1008 / sizeof(XPV) - 1];
477 while (xpv < xpvend) {
478 xpv->xpv_pv = (char*)(xpv + 1);
485 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
486 #define del_XIV(p) Safefree((char*)p)
488 #define new_XIV() (void*)new_xiv()
489 #define del_XIV(p) del_xiv((XPVIV*) p)
493 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
494 #define del_XNV(p) Safefree((char*)p)
496 #define new_XNV() (void*)new_xnv()
497 #define del_XNV(p) del_xnv((XPVNV*) p)
501 #define new_XRV() (void*)safemalloc(sizeof(XRV))
502 #define del_XRV(p) Safefree((char*)p)
504 #define new_XRV() (void*)new_xrv()
505 #define del_XRV(p) del_xrv((XRV*) p)
509 #define new_XPV() (void*)safemalloc(sizeof(XPV))
510 #define del_XPV(p) Safefree((char*)p)
512 #define new_XPV() (void*)new_xpv()
513 #define del_XPV(p) del_xpv((XPV *)p)
517 # define my_safemalloc(s) safemalloc(s)
518 # define my_safefree(s) safefree(s)
521 S_my_safemalloc(MEM_SIZE size)
524 New(717, p, size, char);
527 # define my_safefree(s) Safefree(s)
530 #define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
531 #define del_XPVIV(p) my_safefree((char*)p)
533 #define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
534 #define del_XPVNV(p) my_safefree((char*)p)
536 #define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
537 #define del_XPVMG(p) my_safefree((char*)p)
539 #define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
540 #define del_XPVLV(p) my_safefree((char*)p)
542 #define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
543 #define del_XPVAV(p) my_safefree((char*)p)
545 #define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
546 #define del_XPVHV(p) my_safefree((char*)p)
548 #define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
549 #define del_XPVCV(p) my_safefree((char*)p)
551 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
552 #define del_XPVGV(p) my_safefree((char*)p)
554 #define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
555 #define del_XPVBM(p) my_safefree((char*)p)
557 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
558 #define del_XPVFM(p) my_safefree((char*)p)
560 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
561 #define del_XPVIO(p) my_safefree((char*)p)
564 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
574 if (SvTYPE(sv) == mt)
580 switch (SvTYPE(sv)) {
601 else if (mt < SVt_PVIV)
618 pv = (char*)SvRV(sv);
622 nv = (NV)(unsigned long)pv;
638 else if (mt == SVt_NV)
649 del_XPVIV(SvANY(sv));
659 del_XPVNV(SvANY(sv));
669 del_XPVMG(SvANY(sv));
672 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
677 Perl_croak(aTHX_ "Can't upgrade to undef");
679 SvANY(sv) = new_XIV();
683 SvANY(sv) = new_XNV();
687 SvANY(sv) = new_XRV();
691 SvANY(sv) = new_XPV();
697 SvANY(sv) = new_XPVIV();
707 SvANY(sv) = new_XPVNV();
715 SvANY(sv) = new_XPVMG();
725 SvANY(sv) = new_XPVLV();
739 SvANY(sv) = new_XPVAV();
754 SvANY(sv) = new_XPVHV();
770 SvANY(sv) = new_XPVCV();
771 Zero(SvANY(sv), 1, XPVCV);
781 SvANY(sv) = new_XPVGV();
796 SvANY(sv) = new_XPVBM();
809 SvANY(sv) = new_XPVFM();
810 Zero(SvANY(sv), 1, XPVFM);
820 SvANY(sv) = new_XPVIO();
821 Zero(SvANY(sv), 1, XPVIO);
832 SvFLAGS(sv) &= ~SVTYPEMASK;
838 Perl_sv_backoff(pTHX_ register SV *sv)
843 SvLEN(sv) += SvIVX(sv);
844 SvPVX(sv) -= SvIVX(sv);
846 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
848 SvFLAGS(sv) &= ~SVf_OOK;
853 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
858 if (newlen >= 0x10000) {
859 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
862 #endif /* HAS_64K_LIMIT */
865 if (SvTYPE(sv) < SVt_PV) {
866 sv_upgrade(sv, SVt_PV);
869 else if (SvOOK(sv)) { /* pv is offset? */
872 if (newlen > SvLEN(sv))
873 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
875 if (newlen >= 0x10000)
881 if (newlen > SvLEN(sv)) { /* need more room? */
882 if (SvLEN(sv) && s) {
883 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
884 STRLEN l = malloced_size((void*)SvPVX(sv));
890 Renew(s,newlen,char);
893 New(703,s,newlen,char);
895 SvLEN_set(sv, newlen);
901 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
903 SV_CHECK_THINKFIRST(sv);
904 switch (SvTYPE(sv)) {
906 sv_upgrade(sv, SVt_IV);
909 sv_upgrade(sv, SVt_PVNV);
913 sv_upgrade(sv, SVt_PVIV);
924 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
925 PL_op_desc[PL_op->op_type]);
928 (void)SvIOK_only(sv); /* validate number */
934 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
941 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
949 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
956 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
958 SV_CHECK_THINKFIRST(sv);
959 switch (SvTYPE(sv)) {
962 sv_upgrade(sv, SVt_NV);
967 sv_upgrade(sv, SVt_PVNV);
978 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
979 PL_op_name[PL_op->op_type]);
983 (void)SvNOK_only(sv); /* validate number */
988 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
995 S_not_a_number(pTHX_ SV *sv)
1001 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1002 /* each *s can expand to 4 chars + "...\0",
1003 i.e. need room for 8 chars */
1005 for (s = SvPVX(sv); *s && d < limit; s++) {
1007 if (ch & 128 && !isPRINT_LC(ch)) {
1016 else if (ch == '\r') {
1020 else if (ch == '\f') {
1024 else if (ch == '\\') {
1028 else if (isPRINT_LC(ch))
1043 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
1044 PL_op_name[PL_op->op_type]);
1046 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
1049 /* the number can be converted to integer with atol() or atoll() */
1050 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1051 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1052 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1053 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1055 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1056 until proven guilty, assume that things are not that bad... */
1059 Perl_sv_2iv(pTHX_ register SV *sv)
1063 if (SvGMAGICAL(sv)) {
1068 return I_V(SvNVX(sv));
1070 if (SvPOKp(sv) && SvLEN(sv))
1073 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1075 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1076 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1081 if (SvTHINKFIRST(sv)) {
1084 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1085 return SvIV(tmpstr);
1086 return (IV)SvRV(sv);
1088 if (SvREADONLY(sv) && !SvOK(sv)) {
1090 if (ckWARN(WARN_UNINITIALIZED))
1091 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1097 return (IV)(SvUVX(sv));
1104 /* We can cache the IV/UV value even if it not good enough
1105 * to reconstruct NV, since the conversion to PV will prefer
1109 if (SvTYPE(sv) == SVt_NV)
1110 sv_upgrade(sv, SVt_PVNV);
1113 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1114 SvIVX(sv) = I_V(SvNVX(sv));
1116 SvUVX(sv) = U_V(SvNVX(sv));
1120 DEBUG_c(PerlIO_printf(Perl_debug_log,
1121 "0x%" PERL_PRIx64 " 2iv(%" PERL_PRIu64 " => %" PERL_PRId64 ") (as unsigned)\n",
1123 (UV)SvUVX(sv), (IV)SvUVX(sv)));
1125 DEBUG_c(PerlIO_printf(Perl_debug_log,
1126 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1128 (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
1130 return (IV)SvUVX(sv);
1133 else if (SvPOKp(sv) && SvLEN(sv)) {
1134 I32 numtype = looks_like_number(sv);
1136 /* We want to avoid a possible problem when we cache an IV which
1137 may be later translated to an NV, and the resulting NV is not
1138 the translation of the initial data.
1140 This means that if we cache such an IV, we need to cache the
1141 NV as well. Moreover, we trade speed for space, and do not
1142 cache the NV if not needed.
1144 if (numtype & IS_NUMBER_NOT_IV) {
1145 /* May be not an integer. Need to cache NV if we cache IV
1146 * - otherwise future conversion to NV will be wrong. */
1149 d = Atof(SvPVX(sv));
1151 if (SvTYPE(sv) < SVt_PVNV)
1152 sv_upgrade(sv, SVt_PVNV);
1156 #if defined(USE_LONG_DOUBLE)
1157 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1158 (unsigned long)sv, SvNVX(sv)));
1160 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1161 (unsigned long)sv, SvNVX(sv)));
1163 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1164 SvIVX(sv) = I_V(SvNVX(sv));
1166 SvUVX(sv) = U_V(SvNVX(sv));
1172 /* The NV may be reconstructed from IV - safe to cache IV,
1173 which may be calculated by atol(). */
1174 if (SvTYPE(sv) == SVt_PV)
1175 sv_upgrade(sv, SVt_PVIV);
1177 SvIVX(sv) = Atol(SvPVX(sv));
1179 else { /* Not a number. Cache 0. */
1182 if (SvTYPE(sv) < SVt_PVIV)
1183 sv_upgrade(sv, SVt_PVIV);
1186 if (ckWARN(WARN_NUMERIC))
1192 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1193 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1194 if (SvTYPE(sv) < SVt_IV)
1195 /* Typically the caller expects that sv_any is not NULL now. */
1196 sv_upgrade(sv, SVt_IV);
1199 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1200 (unsigned long)sv,(long)SvIVX(sv)));
1201 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1205 Perl_sv_2uv(pTHX_ register SV *sv)
1209 if (SvGMAGICAL(sv)) {
1214 return U_V(SvNVX(sv));
1215 if (SvPOKp(sv) && SvLEN(sv))
1218 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1220 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1221 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1226 if (SvTHINKFIRST(sv)) {
1229 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1230 return SvUV(tmpstr);
1231 return (UV)SvRV(sv);
1233 if (SvREADONLY(sv) && !SvOK(sv)) {
1235 if (ckWARN(WARN_UNINITIALIZED))
1236 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1245 return (UV)SvIVX(sv);
1249 /* We can cache the IV/UV value even if it not good enough
1250 * to reconstruct NV, since the conversion to PV will prefer
1253 if (SvTYPE(sv) == SVt_NV)
1254 sv_upgrade(sv, SVt_PVNV);
1256 if (SvNVX(sv) >= -0.5) {
1258 SvUVX(sv) = U_V(SvNVX(sv));
1261 SvIVX(sv) = I_V(SvNVX(sv));
1264 DEBUG_c(PerlIO_printf(Perl_debug_log,
1265 "0x%" PERL_PRIx64 " 2uv(%" PERL_PRId64 " => %" PERL_PRIu64 ") (as signed)\n",
1266 (unsigned long)sv,(long)SvIVX(sv),
1267 (long)(UV)SvIVX(sv)));
1269 DEBUG_c(PerlIO_printf(Perl_debug_log,
1270 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1271 (unsigned long)sv,(long)SvIVX(sv),
1272 (long)(UV)SvIVX(sv)));
1274 return (UV)SvIVX(sv);
1277 else if (SvPOKp(sv) && SvLEN(sv)) {
1278 I32 numtype = looks_like_number(sv);
1280 /* We want to avoid a possible problem when we cache a UV which
1281 may be later translated to an NV, and the resulting NV is not
1282 the translation of the initial data.
1284 This means that if we cache such a UV, we need to cache the
1285 NV as well. Moreover, we trade speed for space, and do not
1286 cache the NV if not needed.
1288 if (numtype & IS_NUMBER_NOT_IV) {
1289 /* May be not an integer. Need to cache NV if we cache IV
1290 * - otherwise future conversion to NV will be wrong. */
1293 d = Atof(SvPVX(sv));
1295 if (SvTYPE(sv) < SVt_PVNV)
1296 sv_upgrade(sv, SVt_PVNV);
1300 #if defined(USE_LONG_DOUBLE)
1301 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1302 (unsigned long)sv, SvNVX(sv)));
1304 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1305 (unsigned long)sv, SvNVX(sv)));
1307 if (SvNVX(sv) < -0.5) {
1308 SvIVX(sv) = I_V(SvNVX(sv));
1311 SvUVX(sv) = U_V(SvNVX(sv));
1315 else if (numtype & IS_NUMBER_NEG) {
1316 /* The NV may be reconstructed from IV - safe to cache IV,
1317 which may be calculated by atol(). */
1318 if (SvTYPE(sv) == SVt_PV)
1319 sv_upgrade(sv, SVt_PVIV);
1321 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1323 else if (numtype) { /* Non-negative */
1324 /* The NV may be reconstructed from UV - safe to cache UV,
1325 which may be calculated by strtoul()/atol. */
1326 if (SvTYPE(sv) == SVt_PV)
1327 sv_upgrade(sv, SVt_PVIV);
1329 (void)SvIsUV_on(sv);
1331 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1332 #else /* no atou(), but we know the number fits into IV... */
1333 /* The only problem may be if it is negative... */
1334 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1337 else { /* Not a number. Cache 0. */
1340 if (SvTYPE(sv) < SVt_PVIV)
1341 sv_upgrade(sv, SVt_PVIV);
1342 SvUVX(sv) = 0; /* We assume that 0s have the
1343 same bitmap in IV and UV. */
1345 (void)SvIsUV_on(sv);
1346 if (ckWARN(WARN_NUMERIC))
1351 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1353 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1354 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1356 if (SvTYPE(sv) < SVt_IV)
1357 /* Typically the caller expects that sv_any is not NULL now. */
1358 sv_upgrade(sv, SVt_IV);
1362 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1363 (unsigned long)sv,SvUVX(sv)));
1364 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1368 Perl_sv_2nv(pTHX_ register SV *sv)
1372 if (SvGMAGICAL(sv)) {
1376 if (SvPOKp(sv) && SvLEN(sv)) {
1378 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1380 return Atof(SvPVX(sv));
1384 return (NV)SvUVX(sv);
1386 return (NV)SvIVX(sv);
1389 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1391 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1392 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1397 if (SvTHINKFIRST(sv)) {
1400 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1401 return SvNV(tmpstr);
1402 return (NV)(unsigned long)SvRV(sv);
1404 if (SvREADONLY(sv) && !SvOK(sv)) {
1406 if (ckWARN(WARN_UNINITIALIZED))
1407 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1411 if (SvTYPE(sv) < SVt_NV) {
1412 if (SvTYPE(sv) == SVt_IV)
1413 sv_upgrade(sv, SVt_PVNV);
1415 sv_upgrade(sv, SVt_NV);
1416 #if defined(USE_LONG_DOUBLE)
1418 RESTORE_NUMERIC_STANDARD();
1419 PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIgldbl ")\n",
1420 (unsigned long)sv, SvNVX(sv));
1421 RESTORE_NUMERIC_LOCAL();
1425 RESTORE_NUMERIC_STANDARD();
1426 PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
1427 (unsigned long)sv, SvNVX(sv));
1428 RESTORE_NUMERIC_LOCAL();
1432 else if (SvTYPE(sv) < SVt_PVNV)
1433 sv_upgrade(sv, SVt_PVNV);
1435 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1437 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1439 else if (SvPOKp(sv) && SvLEN(sv)) {
1441 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1443 SvNVX(sv) = Atof(SvPVX(sv));
1447 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1448 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1449 if (SvTYPE(sv) < SVt_NV)
1450 /* Typically the caller expects that sv_any is not NULL now. */
1451 sv_upgrade(sv, SVt_NV);
1455 #if defined(USE_LONG_DOUBLE)
1457 RESTORE_NUMERIC_STANDARD();
1458 PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1459 (unsigned long)sv, SvNVX(sv));
1460 RESTORE_NUMERIC_LOCAL();
1464 RESTORE_NUMERIC_STANDARD();
1465 PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
1466 (unsigned long)sv, SvNVX(sv));
1467 RESTORE_NUMERIC_LOCAL();
1474 S_asIV(pTHX_ SV *sv)
1476 I32 numtype = looks_like_number(sv);
1479 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1480 return Atol(SvPVX(sv));
1483 if (ckWARN(WARN_NUMERIC))
1486 d = Atof(SvPVX(sv));
1491 S_asUV(pTHX_ SV *sv)
1493 I32 numtype = looks_like_number(sv);
1496 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1497 return Strtoul(SvPVX(sv), Null(char**), 10);
1501 if (ckWARN(WARN_NUMERIC))
1504 return U_V(Atof(SvPVX(sv)));
1508 * Returns a combination of (advisory only - can get false negatives)
1509 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1511 * 0 if does not look like number.
1513 * In fact possible values are 0 and
1514 * IS_NUMBER_TO_INT_BY_ATOL 123
1515 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1516 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1517 * with a possible addition of IS_NUMBER_NEG.
1521 Perl_looks_like_number(pTHX_ SV *sv)
1524 register char *send;
1525 register char *sbegin;
1526 register char *nbegin;
1534 else if (SvPOKp(sv))
1535 sbegin = SvPV(sv, len);
1538 send = sbegin + len;
1545 numtype = IS_NUMBER_NEG;
1552 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1553 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1557 /* next must be digit or the radix separator */
1561 } while (isDIGIT(*s));
1563 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1564 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1566 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1569 #ifdef USE_LOCALE_NUMERIC
1570 || IS_NUMERIC_RADIX(*s)
1574 numtype |= IS_NUMBER_NOT_IV;
1575 while (isDIGIT(*s)) /* optional digits after the radix */
1580 #ifdef USE_LOCALE_NUMERIC
1581 || IS_NUMERIC_RADIX(*s)
1585 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1586 /* no digits before the radix means we need digits after it */
1590 } while (isDIGIT(*s));
1598 /* we can have an optional exponent part */
1599 if (*s == 'e' || *s == 'E') {
1600 numtype &= ~IS_NUMBER_NEG;
1601 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1603 if (*s == '+' || *s == '-')
1608 } while (isDIGIT(*s));
1617 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1618 return IS_NUMBER_TO_INT_BY_ATOL;
1623 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1626 return sv_2pv(sv, &n_a);
1629 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1631 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1634 char *ptr = buf + TYPE_CHARS(UV);
1649 *--ptr = '0' + (uv % 10);
1658 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1663 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1664 char *tmpbuf = tbuf;
1670 if (SvGMAGICAL(sv)) {
1679 (void)sprintf(tmpbuf,"%" PERL_PRIu64,(UV)SvUVX(sv));
1681 (void)sprintf(tmpbuf,"%" PERL_PRId64,(IV)SvIVX(sv));
1684 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1686 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1692 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
1697 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1699 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1700 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1706 if (SvTHINKFIRST(sv)) {
1709 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1710 return SvPV(tmpstr,*lp);
1717 switch (SvTYPE(sv)) {
1719 if ( ((SvFLAGS(sv) &
1720 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1721 == (SVs_OBJECT|SVs_RMG))
1722 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1723 && (mg = mg_find(sv, 'r'))) {
1725 regexp *re = (regexp *)mg->mg_obj;
1728 char *fptr = "msix";
1733 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1735 while(ch = *fptr++) {
1737 reflags[left++] = ch;
1740 reflags[right--] = ch;
1745 reflags[left] = '-';
1749 mg->mg_len = re->prelen + 4 + left;
1750 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1751 Copy("(?", mg->mg_ptr, 2, char);
1752 Copy(reflags, mg->mg_ptr+2, left, char);
1753 Copy(":", mg->mg_ptr+left+2, 1, char);
1754 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1755 mg->mg_ptr[mg->mg_len - 1] = ')';
1756 mg->mg_ptr[mg->mg_len] = 0;
1758 PL_reginterp_cnt += re->program[0].next_off;
1770 case SVt_PVBM: s = "SCALAR"; break;
1771 case SVt_PVLV: s = "LVALUE"; break;
1772 case SVt_PVAV: s = "ARRAY"; break;
1773 case SVt_PVHV: s = "HASH"; break;
1774 case SVt_PVCV: s = "CODE"; break;
1775 case SVt_PVGV: s = "GLOB"; break;
1776 case SVt_PVFM: s = "FORMAT"; break;
1777 case SVt_PVIO: s = "IO"; break;
1778 default: s = "UNKNOWN"; break;
1782 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1786 Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", (UV)sv);
1788 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), NV_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)
4017 char todo[PERL_UCHAR_MAX+1];
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);
4036 i = (unsigned char)*s;
4040 max = (unsigned char)*s++;
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 /* Times 4: a decimal digit takes more than 3 binary digits.
4713 * NV_DIG: mantissa takes than many decimal digits.
4714 * Plus 32: Playing safe. */
4715 char ebuf[IV_DIG * 4 + NV_DIG + 32];
4716 /* large enough for "%#.#f" --chip */
4717 /* what about long double NVs? --jhi */
4728 for (q = p; q < patend && *q != '%'; ++q) ;
4730 sv_catpvn(sv, p, q - p);
4768 case '1': case '2': case '3':
4769 case '4': case '5': case '6':
4770 case '7': case '8': case '9':
4773 width = width * 10 + (*q++ - '0');
4778 i = va_arg(*args, int);
4780 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4782 width = (i < 0) ? -i : i;
4793 i = va_arg(*args, int);
4795 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4796 precis = (i < 0) ? 0 : i;
4802 precis = precis * 10 + (*q++ - '0');
4812 if (*(q + 1) == 'l') { /* lld */
4844 uv = va_arg(*args, int);
4846 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4848 eptr = (char*)utf8buf;
4849 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4853 c = va_arg(*args, int);
4855 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4862 eptr = va_arg(*args, char*);
4864 elen = strlen(eptr);
4867 elen = sizeof nullstr - 1;
4870 else if (svix < svmax) {
4871 eptr = SvPVx(svargs[svix++], elen);
4873 if (has_precis && precis < elen) {
4875 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4878 if (width) { /* fudge width (can't fudge elen) */
4879 width += elen - sv_len_utf8(svargs[svix - 1]);
4887 * The "%_" hack might have to be changed someday,
4888 * if ISO or ANSI decide to use '_' for something.
4889 * So we keep it hidden from users' code.
4893 eptr = SvPVx(va_arg(*args, SV*), elen);
4896 if (has_precis && elen > precis)
4904 uv = (UV)va_arg(*args, void*);
4906 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4921 case 'h': iv = (short)va_arg(*args, int); break;
4923 default: iv = va_arg(*args, IV); break;
4925 default: iv = va_arg(*args, int); break;
4927 case 'l': iv = va_arg(*args, long); break;
4928 case 'V': iv = va_arg(*args, IV); break;
4930 case 'q': iv = va_arg(*args, Quad_t); break;
4935 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4937 case 'h': iv = (short)iv; break;
4941 default: iv = (int)iv; break;
4943 case 'l': iv = (long)iv; break;
4946 case 'q': iv = (Quad_t)iv; break;
4953 esignbuf[esignlen++] = plus;
4957 esignbuf[esignlen++] = '-';
4995 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4997 default: uv = va_arg(*args, UV); break;
4999 default: uv = va_arg(*args, unsigned); break;
5001 case 'l': uv = va_arg(*args, unsigned long); break;
5002 case 'V': uv = va_arg(*args, UV); break;
5004 case 'q': uv = va_arg(*args, Quad_t); break;
5009 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5011 case 'h': uv = (unsigned short)uv; break;
5015 default: uv = (unsigned)uv; break;
5017 case 'l': uv = (unsigned long)uv; break;
5020 case 'q': uv = (Quad_t)uv; break;
5026 eptr = ebuf + sizeof ebuf;
5032 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5038 esignbuf[esignlen++] = '0';
5039 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5045 *--eptr = '0' + dig;
5047 if (alt && *eptr != '0')
5053 *--eptr = '0' + dig;
5055 if (alt && *eptr != '0')
5058 default: /* it had better be ten or less */
5061 *--eptr = '0' + dig;
5062 } while (uv /= base);
5065 elen = (ebuf + sizeof ebuf) - eptr;
5068 zeros = precis - elen;
5069 else if (precis == 0 && elen == 1 && *eptr == '0')
5074 /* FLOATING POINT */
5077 c = 'f'; /* maybe %F isn't supported here */
5083 /* This is evil, but floating point is even more evil */
5086 nv = va_arg(*args, NV);
5088 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5091 if (c != 'e' && c != 'E') {
5093 (void)frexp(nv, &i);
5094 if (i == PERL_INT_MIN)
5095 Perl_die(aTHX_ "panic: frexp");
5097 need = BIT_DIGITS(i);
5099 need += has_precis ? precis : 6; /* known default */
5103 need += 20; /* fudge factor */
5104 if (PL_efloatsize < need) {
5105 Safefree(PL_efloatbuf);
5106 PL_efloatsize = need + 20; /* more fudge */
5107 New(906, PL_efloatbuf, PL_efloatsize, char);
5110 eptr = ebuf + sizeof ebuf;
5113 #ifdef USE_LONG_DOUBLE
5115 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5116 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5121 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5126 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5139 RESTORE_NUMERIC_STANDARD();
5140 (void)sprintf(PL_efloatbuf, eptr, nv);
5141 RESTORE_NUMERIC_LOCAL();
5144 eptr = PL_efloatbuf;
5145 elen = strlen(PL_efloatbuf);
5149 * User-defined locales may include arbitrary characters.
5150 * And, unfortunately, some system may alloc the "C" locale
5151 * to be overridden by a malicious user.
5154 *used_locale = TRUE;
5155 #endif /* LC_NUMERIC */
5162 i = SvCUR(sv) - origlen;
5165 case 'h': *(va_arg(*args, short*)) = i; break;
5167 default: *(va_arg(*args, IV*)) = i; break;
5169 default: *(va_arg(*args, int*)) = i; break;
5171 case 'l': *(va_arg(*args, long*)) = i; break;
5172 case 'V': *(va_arg(*args, IV*)) = i; break;
5174 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5178 else if (svix < svmax)
5179 sv_setuv(svargs[svix++], (UV)i);
5180 continue; /* not "break" */
5186 if (!args && ckWARN(WARN_PRINTF) &&
5187 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5188 SV *msg = sv_newmortal();
5189 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5190 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5194 Perl_sv_catpvf(aTHX_ msg,
5195 "\"%%%c\"", c & 0xFF);
5197 Perl_sv_catpvf(aTHX_ msg,
5198 "\"%%\\%03" PERL_PRIo64 "\"",
5201 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ?
5202 "\"%%%c\"" : "\"%%\\%03o\"",
5206 sv_catpv(msg, "end of string");
5207 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5210 /* output mangled stuff ... */
5216 /* ... right here, because formatting flags should not apply */
5217 SvGROW(sv, SvCUR(sv) + elen + 1);
5219 memcpy(p, eptr, elen);
5222 SvCUR(sv) = p - SvPVX(sv);
5223 continue; /* not "break" */
5226 have = esignlen + zeros + elen;
5227 need = (have > width ? have : width);
5230 SvGROW(sv, SvCUR(sv) + need + 1);
5232 if (esignlen && fill == '0') {
5233 for (i = 0; i < esignlen; i++)
5237 memset(p, fill, gap);
5240 if (esignlen && fill != '0') {
5241 for (i = 0; i < esignlen; i++)
5245 for (i = zeros; i; i--)
5249 memcpy(p, eptr, elen);
5253 memset(p, ' ', gap);
5257 SvCUR(sv) = p - SvPVX(sv);
5268 do_report_used(pTHXo_ SV *sv)
5270 if (SvTYPE(sv) != SVTYPEMASK) {
5271 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
5272 PerlIO_printf(PerlIO_stderr(), "****\n");
5278 do_clean_objs(pTHXo_ SV *sv)
5282 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5283 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
5289 /* XXX Might want to check arrays, etc. */
5292 #ifndef DISABLE_DESTRUCTOR_KLUDGE
5294 do_clean_named_objs(pTHXo_ SV *sv)
5296 if (SvTYPE(sv) == SVt_PVGV) {
5297 if ( SvOBJECT(GvSV(sv)) ||
5298 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
5299 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
5300 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
5301 GvCV(sv) && SvOBJECT(GvCV(sv)) )
5303 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
5311 do_clean_all(pTHXo_ SV *sv)
5313 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
5314 SvFLAGS(sv) |= SVf_BREAK;