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 FCALL this->*f
42 #define VTBL this->*vtbl
43 #else /* !PERL_OBJECT */
46 #endif /* PERL_OBJECT */
48 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
55 (p) = (SV*)safemalloc(sizeof(SV)); \
67 Safefree((char*)(p)); \
72 static I32 registry_size;
74 #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
76 #define REG_REPLACE(sv,a,b) \
78 void* p = sv->sv_any; \
79 I32 h = REGHASH(sv, registry_size); \
81 while (registry[i] != (a)) { \
82 if (++i >= registry_size) \
85 Perl_die(aTHX_ "SV registry bug"); \
90 #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
91 #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
94 S_reg_add(pTHX_ SV *sv)
96 if (PL_sv_count >= (registry_size >> 1))
98 SV **oldreg = registry;
99 I32 oldsize = registry_size;
101 registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
102 Newz(707, registry, registry_size, SV*);
107 for (i = 0; i < oldsize; ++i) {
108 SV* oldsv = oldreg[i];
121 S_reg_remove(pTHX_ SV *sv)
128 S_visit(pTHX_ SVFUNC_t f)
132 for (i = 0; i < registry_size; ++i) {
133 SV* sv = registry[i];
134 if (sv && SvTYPE(sv) != SVTYPEMASK)
140 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
142 if (!(flags & SVf_FAKE))
149 * "A time to plant, and a time to uproot what was planted..."
152 #define plant_SV(p) \
154 SvANY(p) = (void *)PL_sv_root; \
155 SvFLAGS(p) = SVTYPEMASK; \
160 /* sv_mutex must be held while calling uproot_SV() */
161 #define uproot_SV(p) \
164 PL_sv_root = (SV*)SvANY(p); \
186 if (PL_debug & 32768) \
194 S_del_sv(pTHX_ SV *p)
196 if (PL_debug & 32768) {
201 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
203 svend = &sva[SvREFCNT(sva)];
204 if (p >= sv && p < svend)
208 Perl_warn(aTHX_ "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
215 #else /* ! DEBUGGING */
217 #define del_SV(p) plant_SV(p)
219 #endif /* DEBUGGING */
222 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
227 Zero(sva, size, char);
229 /* The first SV in an arena isn't an SV. */
230 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
231 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
232 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
234 PL_sv_arenaroot = sva;
235 PL_sv_root = sva + 1;
237 svend = &sva[SvREFCNT(sva) - 1];
240 SvANY(sv) = (void *)(SV*)(sv + 1);
241 SvFLAGS(sv) = SVTYPEMASK;
245 SvFLAGS(sv) = SVTYPEMASK;
248 /* sv_mutex must be held while calling more_sv() */
255 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
256 PL_nice_chunk = Nullch;
259 char *chunk; /* must use New here to match call to */
260 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
261 sv_add_arena(chunk, 1008, 0);
268 S_visit(pTHX_ SVFUNC_t f)
274 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
275 svend = &sva[SvREFCNT(sva)];
276 for (sv = sva + 1; sv < svend; ++sv) {
277 if (SvTYPE(sv) != SVTYPEMASK)
286 S_do_report_used(pTHX_ SV *sv)
288 if (SvTYPE(sv) != SVTYPEMASK) {
289 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
290 PerlIO_printf(PerlIO_stderr(), "****\n");
296 Perl_sv_report_used(pTHX)
298 visit(FUNC_NAME_TO_PTR(S_do_report_used));
302 S_do_clean_objs(pTHX_ SV *sv)
306 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
307 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
313 /* XXX Might want to check arrays, etc. */
316 #ifndef DISABLE_DESTRUCTOR_KLUDGE
318 S_do_clean_named_objs(pTHX_ SV *sv)
320 if (SvTYPE(sv) == SVt_PVGV) {
321 if ( SvOBJECT(GvSV(sv)) ||
322 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
323 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
324 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
325 GvCV(sv) && SvOBJECT(GvCV(sv)) )
327 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
335 Perl_sv_clean_objs(pTHX)
337 PL_in_clean_objs = TRUE;
338 visit(FUNC_NAME_TO_PTR(S_do_clean_objs));
339 #ifndef DISABLE_DESTRUCTOR_KLUDGE
340 /* some barnacles may yet remain, clinging to typeglobs */
341 visit(FUNC_NAME_TO_PTR(S_do_clean_named_objs));
343 PL_in_clean_objs = FALSE;
347 S_do_clean_all(pTHX_ SV *sv)
349 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
350 SvFLAGS(sv) |= SVf_BREAK;
355 Perl_sv_clean_all(pTHX)
357 PL_in_clean_all = TRUE;
358 visit(FUNC_NAME_TO_PTR(S_do_clean_all));
359 PL_in_clean_all = FALSE;
363 Perl_sv_free_arenas(pTHX)
368 /* Free arenas here, but be careful about fake ones. (We assume
369 contiguity of the fake ones with the corresponding real ones.) */
371 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
372 svanext = (SV*) SvANY(sva);
373 while (svanext && SvFAKE(svanext))
374 svanext = (SV*) SvANY(svanext);
377 Safefree((void *)sva);
381 Safefree(PL_nice_chunk);
382 PL_nice_chunk = Nullch;
383 PL_nice_chunk_size = 0;
397 * See comment in more_xiv() -- RAM.
399 PL_xiv_root = *(IV**)xiv;
401 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
405 S_del_xiv(pTHX_ XPVIV *p)
407 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
409 *(IV**)xiv = PL_xiv_root;
420 New(705, ptr, 1008/sizeof(XPV), XPV);
421 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
422 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
425 xivend = &xiv[1008 / sizeof(IV) - 1];
426 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
428 while (xiv < xivend) {
429 *(IV**)xiv = (IV *)(xiv + 1);
443 PL_xnv_root = *(double**)xnv;
445 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
449 S_del_xnv(pTHX_ XPVNV *p)
451 double* xnv = (double*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
453 *(double**)xnv = PL_xnv_root;
461 register double* xnv;
462 register double* xnvend;
463 New(711, xnv, 1008/sizeof(double), double);
464 xnvend = &xnv[1008 / sizeof(double) - 1];
465 xnv += (sizeof(XPVIV) - 1) / sizeof(double) + 1; /* fudge by sizeof XPVIV */
467 while (xnv < xnvend) {
468 *(double**)xnv = (double*)(xnv + 1);
482 PL_xrv_root = (XRV*)xrv->xrv_rv;
488 S_del_xrv(pTHX_ XRV *p)
491 p->xrv_rv = (SV*)PL_xrv_root;
500 register XRV* xrvend;
501 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
503 xrvend = &xrv[1008 / sizeof(XRV) - 1];
504 while (xrv < xrvend) {
505 xrv->xrv_rv = (SV*)(xrv + 1);
519 PL_xpv_root = (XPV*)xpv->xpv_pv;
525 S_del_xpv(pTHX_ XPV *p)
528 p->xpv_pv = (char*)PL_xpv_root;
537 register XPV* xpvend;
538 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
540 xpvend = &xpv[1008 / sizeof(XPV) - 1];
541 while (xpv < xpvend) {
542 xpv->xpv_pv = (char*)(xpv + 1);
549 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
550 #define del_XIV(p) Safefree((char*)p)
552 #define new_XIV() (void*)new_xiv()
553 #define del_XIV(p) del_xiv((XPVIV*) p)
557 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
558 #define del_XNV(p) Safefree((char*)p)
560 #define new_XNV() (void*)new_xnv()
561 #define del_XNV(p) del_xnv((XPVNV*) p)
565 #define new_XRV() (void*)safemalloc(sizeof(XRV))
566 #define del_XRV(p) Safefree((char*)p)
568 #define new_XRV() (void*)new_xrv()
569 #define del_XRV(p) del_xrv((XRV*) p)
573 #define new_XPV() (void*)safemalloc(sizeof(XPV))
574 #define del_XPV(p) Safefree((char*)p)
576 #define new_XPV() (void*)new_xpv()
577 #define del_XPV(p) del_xpv((XPV *)p)
581 # define my_safemalloc(s) safemalloc(s)
582 # define my_safefree(s) safefree(s)
585 S_my_safemalloc(MEM_SIZE size)
588 New(717, p, size, char);
591 # define my_safefree(s) Safefree(s)
594 #define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
595 #define del_XPVIV(p) my_safefree((char*)p)
597 #define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
598 #define del_XPVNV(p) my_safefree((char*)p)
600 #define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
601 #define del_XPVMG(p) my_safefree((char*)p)
603 #define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
604 #define del_XPVLV(p) my_safefree((char*)p)
606 #define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
607 #define del_XPVAV(p) my_safefree((char*)p)
609 #define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
610 #define del_XPVHV(p) my_safefree((char*)p)
612 #define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
613 #define del_XPVCV(p) my_safefree((char*)p)
615 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
616 #define del_XPVGV(p) my_safefree((char*)p)
618 #define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
619 #define del_XPVBM(p) my_safefree((char*)p)
621 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
622 #define del_XPVFM(p) my_safefree((char*)p)
624 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
625 #define del_XPVIO(p) my_safefree((char*)p)
628 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
638 if (SvTYPE(sv) == mt)
644 switch (SvTYPE(sv)) {
659 nv = (double)SvIVX(sv);
665 else if (mt < SVt_PVIV)
682 pv = (char*)SvRV(sv);
686 nv = (double)(unsigned long)pv;
702 else if (mt == SVt_NV)
713 del_XPVIV(SvANY(sv));
723 del_XPVNV(SvANY(sv));
733 del_XPVMG(SvANY(sv));
736 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
741 Perl_croak(aTHX_ "Can't upgrade to undef");
743 SvANY(sv) = new_XIV();
747 SvANY(sv) = new_XNV();
751 SvANY(sv) = new_XRV();
755 SvANY(sv) = new_XPV();
761 SvANY(sv) = new_XPVIV();
771 SvANY(sv) = new_XPVNV();
779 SvANY(sv) = new_XPVMG();
789 SvANY(sv) = new_XPVLV();
803 SvANY(sv) = new_XPVAV();
818 SvANY(sv) = new_XPVHV();
834 SvANY(sv) = new_XPVCV();
835 Zero(SvANY(sv), 1, XPVCV);
845 SvANY(sv) = new_XPVGV();
860 SvANY(sv) = new_XPVBM();
873 SvANY(sv) = new_XPVFM();
874 Zero(SvANY(sv), 1, XPVFM);
884 SvANY(sv) = new_XPVIO();
885 Zero(SvANY(sv), 1, XPVIO);
896 SvFLAGS(sv) &= ~SVTYPEMASK;
902 Perl_sv_backoff(pTHX_ register SV *sv)
907 SvLEN(sv) += SvIVX(sv);
908 SvPVX(sv) -= SvIVX(sv);
910 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
912 SvFLAGS(sv) &= ~SVf_OOK;
917 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
922 if (newlen >= 0x10000) {
923 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
926 #endif /* HAS_64K_LIMIT */
929 if (SvTYPE(sv) < SVt_PV) {
930 sv_upgrade(sv, SVt_PV);
933 else if (SvOOK(sv)) { /* pv is offset? */
936 if (newlen > SvLEN(sv))
937 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
939 if (newlen >= 0x10000)
945 if (newlen > SvLEN(sv)) { /* need more room? */
946 if (SvLEN(sv) && s) {
947 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
948 STRLEN l = malloced_size((void*)SvPVX(sv));
954 Renew(s,newlen,char);
957 New(703,s,newlen,char);
959 SvLEN_set(sv, newlen);
965 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
967 SV_CHECK_THINKFIRST(sv);
968 switch (SvTYPE(sv)) {
970 sv_upgrade(sv, SVt_IV);
973 sv_upgrade(sv, SVt_PVNV);
977 sv_upgrade(sv, SVt_PVIV);
988 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
989 PL_op_desc[PL_op->op_type]);
992 (void)SvIOK_only(sv); /* validate number */
998 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1005 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1013 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1020 Perl_sv_setnv(pTHX_ register SV *sv, double num)
1022 SV_CHECK_THINKFIRST(sv);
1023 switch (SvTYPE(sv)) {
1026 sv_upgrade(sv, SVt_NV);
1031 sv_upgrade(sv, SVt_PVNV);
1042 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1043 PL_op_name[PL_op->op_type]);
1047 (void)SvNOK_only(sv); /* validate number */
1052 Perl_sv_setnv_mg(pTHX_ register SV *sv, double num)
1059 S_not_a_number(pTHX_ SV *sv)
1065 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1066 /* each *s can expand to 4 chars + "...\0",
1067 i.e. need room for 8 chars */
1069 for (s = SvPVX(sv); *s && d < limit; s++) {
1071 if (ch & 128 && !isPRINT_LC(ch)) {
1080 else if (ch == '\r') {
1084 else if (ch == '\f') {
1088 else if (ch == '\\') {
1092 else if (isPRINT_LC(ch))
1107 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
1108 PL_op_name[PL_op->op_type]);
1110 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
1113 /* the number can be converted to _integer_ with atol() */
1114 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1115 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1116 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1117 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1119 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1120 until proven guilty, assume that things are not that bad... */
1123 Perl_sv_2iv(pTHX_ register SV *sv)
1127 if (SvGMAGICAL(sv)) {
1132 return I_V(SvNVX(sv));
1134 if (SvPOKp(sv) && SvLEN(sv))
1137 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1139 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1140 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1145 if (SvTHINKFIRST(sv)) {
1148 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1149 return SvIV(tmpstr);
1150 return (IV)SvRV(sv);
1152 if (SvREADONLY(sv)) {
1154 return I_V(SvNVX(sv));
1156 if (SvPOKp(sv) && SvLEN(sv))
1160 if (ckWARN(WARN_UNINITIALIZED))
1161 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1168 return (IV)(SvUVX(sv));
1175 /* We can cache the IV/UV value even if it not good enough
1176 * to reconstruct NV, since the conversion to PV will prefer
1177 * NV over IV/UV. XXXX 64-bit?
1180 if (SvTYPE(sv) == SVt_NV)
1181 sv_upgrade(sv, SVt_PVNV);
1184 if (SvNVX(sv) < (double)IV_MAX + 0.5)
1185 SvIVX(sv) = I_V(SvNVX(sv));
1187 SvUVX(sv) = U_V(SvNVX(sv));
1190 DEBUG_c(PerlIO_printf(Perl_debug_log,
1191 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1193 (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
1194 return (IV)SvUVX(sv);
1197 else if (SvPOKp(sv) && SvLEN(sv)) {
1198 I32 numtype = looks_like_number(sv);
1200 /* We want to avoid a possible problem when we cache an IV which
1201 may be later translated to an NV, and the resulting NV is not
1202 the translation of the initial data.
1204 This means that if we cache such an IV, we need to cache the
1205 NV as well. Moreover, we trade speed for space, and do not
1206 cache the NV if not needed.
1208 if (numtype & IS_NUMBER_NOT_IV) {
1209 /* May be not an integer. Need to cache NV if we cache IV
1210 * - otherwise future conversion to NV will be wrong. */
1213 d = Atof(SvPVX(sv));
1215 if (SvTYPE(sv) < SVt_PVNV)
1216 sv_upgrade(sv, SVt_PVNV);
1220 DEBUG_c(PerlIO_printf(Perl_debug_log,
1221 "0x%lx 2nv(%g)\n",(unsigned long)sv,
1223 if (SvNVX(sv) < (double)IV_MAX + 0.5)
1224 SvIVX(sv) = I_V(SvNVX(sv));
1226 SvUVX(sv) = U_V(SvNVX(sv));
1232 /* The NV may be reconstructed from IV - safe to cache IV,
1233 which may be calculated by atol(). */
1234 if (SvTYPE(sv) == SVt_PV)
1235 sv_upgrade(sv, SVt_PVIV);
1237 SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
1239 else { /* Not a number. Cache 0. */
1242 if (SvTYPE(sv) < SVt_PVIV)
1243 sv_upgrade(sv, SVt_PVIV);
1246 if (ckWARN(WARN_NUMERIC))
1252 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1253 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1254 if (SvTYPE(sv) < SVt_IV)
1255 /* Typically the caller expects that sv_any is not NULL now. */
1256 sv_upgrade(sv, SVt_IV);
1259 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1260 (unsigned long)sv,(long)SvIVX(sv)));
1261 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1265 Perl_sv_2uv(pTHX_ register SV *sv)
1269 if (SvGMAGICAL(sv)) {
1274 return U_V(SvNVX(sv));
1275 if (SvPOKp(sv) && SvLEN(sv))
1278 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1280 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1281 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1286 if (SvTHINKFIRST(sv)) {
1289 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1290 return SvUV(tmpstr);
1291 return (UV)SvRV(sv);
1293 if (SvREADONLY(sv)) {
1295 return U_V(SvNVX(sv));
1297 if (SvPOKp(sv) && SvLEN(sv))
1301 if (ckWARN(WARN_UNINITIALIZED))
1302 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1312 return (UV)SvIVX(sv);
1316 /* We can cache the IV/UV value even if it not good enough
1317 * to reconstruct NV, since the conversion to PV will prefer
1318 * NV over IV/UV. XXXX 64-bit?
1320 if (SvTYPE(sv) == SVt_NV)
1321 sv_upgrade(sv, SVt_PVNV);
1323 if (SvNVX(sv) >= -0.5) {
1325 SvUVX(sv) = U_V(SvNVX(sv));
1328 SvIVX(sv) = I_V(SvNVX(sv));
1330 DEBUG_c(PerlIO_printf(Perl_debug_log,
1331 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1332 (unsigned long)sv,(long)SvIVX(sv),
1333 (long)(UV)SvIVX(sv)));
1334 return (UV)SvIVX(sv);
1337 else if (SvPOKp(sv) && SvLEN(sv)) {
1338 I32 numtype = looks_like_number(sv);
1340 /* We want to avoid a possible problem when we cache a UV which
1341 may be later translated to an NV, and the resulting NV is not
1342 the translation of the initial data.
1344 This means that if we cache such a UV, we need to cache the
1345 NV as well. Moreover, we trade speed for space, and do not
1346 cache the NV if not needed.
1348 if (numtype & IS_NUMBER_NOT_IV) {
1349 /* May be not an integer. Need to cache NV if we cache IV
1350 * - otherwise future conversion to NV will be wrong. */
1353 d = Atof(SvPVX(sv)); /* XXXX 64-bit? */
1355 if (SvTYPE(sv) < SVt_PVNV)
1356 sv_upgrade(sv, SVt_PVNV);
1360 DEBUG_c(PerlIO_printf(Perl_debug_log,
1361 "0x%lx 2nv(%g)\n",(unsigned long)sv,
1363 if (SvNVX(sv) < -0.5) {
1364 SvIVX(sv) = I_V(SvNVX(sv));
1367 SvUVX(sv) = U_V(SvNVX(sv));
1371 else if (numtype & IS_NUMBER_NEG) {
1372 /* The NV may be reconstructed from IV - safe to cache IV,
1373 which may be calculated by atol(). */
1374 if (SvTYPE(sv) == SVt_PV)
1375 sv_upgrade(sv, SVt_PVIV);
1377 SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1379 else if (numtype) { /* Non-negative */
1380 /* The NV may be reconstructed from UV - safe to cache UV,
1381 which may be calculated by strtoul()/atol. */
1382 if (SvTYPE(sv) == SVt_PV)
1383 sv_upgrade(sv, SVt_PVIV);
1385 (void)SvIsUV_on(sv);
1387 SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
1388 #else /* no atou(), but we know the number fits into IV... */
1389 /* The only problem may be if it is negative... */
1390 SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1393 else { /* Not a number. Cache 0. */
1396 if (SvTYPE(sv) < SVt_PVIV)
1397 sv_upgrade(sv, SVt_PVIV);
1398 SvUVX(sv) = 0; /* We assume that 0s have the
1399 same bitmap in IV and UV. */
1401 (void)SvIsUV_on(sv);
1402 if (ckWARN(WARN_NUMERIC))
1407 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1409 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1410 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1412 if (SvTYPE(sv) < SVt_IV)
1413 /* Typically the caller expects that sv_any is not NULL now. */
1414 sv_upgrade(sv, SVt_IV);
1418 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1419 (unsigned long)sv,SvUVX(sv)));
1420 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1424 Perl_sv_2nv(pTHX_ register SV *sv)
1428 if (SvGMAGICAL(sv)) {
1432 if (SvPOKp(sv) && SvLEN(sv)) {
1434 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1436 return Atof(SvPVX(sv));
1440 return (double)SvUVX(sv);
1442 return (double)SvIVX(sv);
1445 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1447 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1448 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1453 if (SvTHINKFIRST(sv)) {
1456 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1457 return SvNV(tmpstr);
1458 return (double)(unsigned long)SvRV(sv);
1460 if (SvREADONLY(sv)) {
1462 if (SvPOKp(sv) && SvLEN(sv)) {
1463 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1465 return Atof(SvPVX(sv));
1469 return (double)SvUVX(sv);
1471 return (double)SvIVX(sv);
1473 if (ckWARN(WARN_UNINITIALIZED))
1474 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1478 if (SvTYPE(sv) < SVt_NV) {
1479 if (SvTYPE(sv) == SVt_IV)
1480 sv_upgrade(sv, SVt_PVNV);
1482 sv_upgrade(sv, SVt_NV);
1484 RESTORE_NUMERIC_STANDARD();
1485 PerlIO_printf(Perl_debug_log,
1486 "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv));
1487 RESTORE_NUMERIC_LOCAL();
1490 else if (SvTYPE(sv) < SVt_PVNV)
1491 sv_upgrade(sv, SVt_PVNV);
1493 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1495 SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv);
1497 else if (SvPOKp(sv) && SvLEN(sv)) {
1499 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1501 SvNVX(sv) = Atof(SvPVX(sv));
1505 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1506 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1507 if (SvTYPE(sv) < SVt_NV)
1508 /* Typically the caller expects that sv_any is not NULL now. */
1509 sv_upgrade(sv, SVt_NV);
1514 RESTORE_NUMERIC_STANDARD();
1515 PerlIO_printf(Perl_debug_log,
1516 "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv));
1517 RESTORE_NUMERIC_LOCAL();
1523 S_asIV(pTHX_ SV *sv)
1525 I32 numtype = looks_like_number(sv);
1528 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1529 return atol(SvPVX(sv)); /* XXXX 64-bit? */
1532 if (ckWARN(WARN_NUMERIC))
1535 d = Atof(SvPVX(sv));
1540 S_asUV(pTHX_ SV *sv)
1542 I32 numtype = looks_like_number(sv);
1545 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1546 return strtoul(SvPVX(sv), Null(char**), 10);
1550 if (ckWARN(WARN_NUMERIC))
1553 return U_V(Atof(SvPVX(sv)));
1557 * Returns a combination of (advisory only - can get false negatives)
1558 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1560 * 0 if does not look like number.
1562 * In fact possible values are 0 and
1563 * IS_NUMBER_TO_INT_BY_ATOL 123
1564 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1565 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1566 * with a possible addition of IS_NUMBER_NEG.
1570 Perl_looks_like_number(pTHX_ SV *sv)
1572 /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
1573 * using atof() may lose precision. */
1575 register char *send;
1576 register char *sbegin;
1577 register char *nbegin;
1585 else if (SvPOKp(sv))
1586 sbegin = SvPV(sv, len);
1589 send = sbegin + len;
1596 numtype = IS_NUMBER_NEG;
1603 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1604 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1608 /* next must be digit or the radix separator */
1612 } while (isDIGIT(*s));
1614 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1615 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1617 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1620 #ifdef USE_LOCALE_NUMERIC
1621 || IS_NUMERIC_RADIX(*s)
1625 numtype |= IS_NUMBER_NOT_IV;
1626 while (isDIGIT(*s)) /* optional digits after the radix */
1631 #ifdef USE_LOCALE_NUMERIC
1632 || IS_NUMERIC_RADIX(*s)
1636 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1637 /* no digits before the radix means we need digits after it */
1641 } while (isDIGIT(*s));
1649 /* we can have an optional exponent part */
1650 if (*s == 'e' || *s == 'E') {
1651 numtype &= ~IS_NUMBER_NEG;
1652 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1654 if (*s == '+' || *s == '-')
1659 } while (isDIGIT(*s));
1668 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1669 return IS_NUMBER_TO_INT_BY_ATOL;
1674 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1677 return sv_2pv(sv, &n_a);
1680 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1682 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1685 char *ptr = buf + TYPE_CHARS(UV);
1700 *--ptr = '0' + (uv % 10);
1709 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1714 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1715 char *tmpbuf = tbuf;
1721 if (SvGMAGICAL(sv)) {
1727 if (SvIOKp(sv)) { /* XXXX 64-bit? */
1729 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1731 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1736 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1741 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1743 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1744 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1750 if (SvTHINKFIRST(sv)) {
1753 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1754 return SvPV(tmpstr,*lp);
1761 switch (SvTYPE(sv)) {
1763 if ( ((SvFLAGS(sv) &
1764 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1765 == (SVs_OBJECT|SVs_RMG))
1766 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1767 && (mg = mg_find(sv, 'r'))) {
1769 regexp *re = (regexp *)mg->mg_obj;
1772 char *fptr = "msix";
1777 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1779 while(ch = *fptr++) {
1781 reflags[left++] = ch;
1784 reflags[right--] = ch;
1789 reflags[left] = '-';
1793 mg->mg_len = re->prelen + 4 + left;
1794 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1795 Copy("(?", mg->mg_ptr, 2, char);
1796 Copy(reflags, mg->mg_ptr+2, left, char);
1797 Copy(":", mg->mg_ptr+left+2, 1, char);
1798 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1799 mg->mg_ptr[mg->mg_len - 1] = ')';
1800 mg->mg_ptr[mg->mg_len] = 0;
1802 PL_reginterp_cnt += re->program[0].next_off;
1814 case SVt_PVBM: s = "SCALAR"; break;
1815 case SVt_PVLV: s = "LVALUE"; break;
1816 case SVt_PVAV: s = "ARRAY"; break;
1817 case SVt_PVHV: s = "HASH"; break;
1818 case SVt_PVCV: s = "CODE"; break;
1819 case SVt_PVGV: s = "GLOB"; break;
1820 case SVt_PVFM: s = "FORMAT"; break;
1821 case SVt_PVIO: s = "IO"; break;
1822 default: s = "UNKNOWN"; break;
1826 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1830 Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
1836 if (SvREADONLY(sv)) {
1837 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1838 /* XXXX 64-bit? IV may have better precision... */
1839 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1847 tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
1849 tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
1856 if (ckWARN(WARN_UNINITIALIZED))
1857 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1863 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1864 /* XXXX 64-bit? IV may have better precision... */
1865 if (SvTYPE(sv) < SVt_PVNV)
1866 sv_upgrade(sv, SVt_PVNV);
1869 olderrno = errno; /* some Xenix systems wipe out errno here */
1871 if (SvNVX(sv) == 0.0)
1872 (void)strcpy(s,"0");
1876 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1879 #ifdef FIXNEGATIVEZERO
1880 if (*s == '-' && s[1] == '0' && !s[2])
1889 else if (SvIOKp(sv)) {
1890 U32 isIOK = SvIOK(sv);
1891 char buf[TYPE_CHARS(UV)];
1894 if (SvTYPE(sv) < SVt_PVIV)
1895 sv_upgrade(sv, SVt_PVIV);
1897 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1898 sv_setpvn(sv, ptr, ebuf - ptr);
1902 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1903 sv_setpvn(sv, ptr, ebuf - ptr);
1913 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1914 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1916 if (SvTYPE(sv) < SVt_PV)
1917 /* Typically the caller expects that sv_any is not NULL now. */
1918 sv_upgrade(sv, SVt_PV);
1921 *lp = s - SvPVX(sv);
1924 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1928 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1929 /* Sneaky stuff here */
1933 tsv = newSVpv(tmpbuf, 0);
1949 len = strlen(tmpbuf);
1951 #ifdef FIXNEGATIVEZERO
1952 if (len == 2 && t[0] == '-' && t[1] == '0') {
1957 (void)SvUPGRADE(sv, SVt_PV);
1959 s = SvGROW(sv, len + 1);
1967 /* This function is only called on magical items */
1969 Perl_sv_2bool(pTHX_ register SV *sv)
1979 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1980 return SvTRUE(tmpsv);
1981 return SvRV(sv) != 0;
1984 register XPV* Xpvtmp;
1985 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1986 (*Xpvtmp->xpv_pv > '0' ||
1987 Xpvtmp->xpv_cur > 1 ||
1988 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
1995 return SvIVX(sv) != 0;
1998 return SvNVX(sv) != 0.0;
2005 /* Note: sv_setsv() should not be called with a source string that needs
2006 * to be reused, since it may destroy the source string if it is marked
2011 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2014 register U32 sflags;
2020 SV_CHECK_THINKFIRST(dstr);
2022 sstr = &PL_sv_undef;
2023 stype = SvTYPE(sstr);
2024 dtype = SvTYPE(dstr);
2028 /* There's a lot of redundancy below but we're going for speed here */
2033 if (dtype != SVt_PVGV) {
2034 (void)SvOK_off(dstr);
2042 sv_upgrade(dstr, SVt_IV);
2045 sv_upgrade(dstr, SVt_PVNV);
2049 sv_upgrade(dstr, SVt_PVIV);
2052 (void)SvIOK_only(dstr);
2053 SvIVX(dstr) = SvIVX(sstr);
2066 sv_upgrade(dstr, SVt_NV);
2071 sv_upgrade(dstr, SVt_PVNV);
2074 SvNVX(dstr) = SvNVX(sstr);
2075 (void)SvNOK_only(dstr);
2083 sv_upgrade(dstr, SVt_RV);
2084 else if (dtype == SVt_PVGV &&
2085 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2088 if (PL_curcop->cop_stash != GvSTASH(dstr))
2089 GvIMPORTED_on(dstr);
2099 sv_upgrade(dstr, SVt_PV);
2102 if (dtype < SVt_PVIV)
2103 sv_upgrade(dstr, SVt_PVIV);
2106 if (dtype < SVt_PVNV)
2107 sv_upgrade(dstr, SVt_PVNV);
2114 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2115 PL_op_name[PL_op->op_type]);
2117 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2121 if (dtype <= SVt_PVGV) {
2123 if (dtype != SVt_PVGV) {
2124 char *name = GvNAME(sstr);
2125 STRLEN len = GvNAMELEN(sstr);
2126 sv_upgrade(dstr, SVt_PVGV);
2127 sv_magic(dstr, dstr, '*', name, len);
2128 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2129 GvNAME(dstr) = savepvn(name, len);
2130 GvNAMELEN(dstr) = len;
2131 SvFAKE_on(dstr); /* can coerce to non-glob */
2133 /* ahem, death to those who redefine active sort subs */
2134 else if (PL_curstackinfo->si_type == PERLSI_SORT
2135 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2136 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2138 (void)SvOK_off(dstr);
2139 GvINTRO_off(dstr); /* one-shot flag */
2141 GvGP(dstr) = gp_ref(GvGP(sstr));
2143 if (PL_curcop->cop_stash != GvSTASH(dstr))
2144 GvIMPORTED_on(dstr);
2151 if (SvGMAGICAL(sstr)) {
2153 if (SvTYPE(sstr) != stype) {
2154 stype = SvTYPE(sstr);
2155 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2159 if (stype == SVt_PVLV)
2160 (void)SvUPGRADE(dstr, SVt_PVNV);
2162 (void)SvUPGRADE(dstr, stype);
2165 sflags = SvFLAGS(sstr);
2167 if (sflags & SVf_ROK) {
2168 if (dtype >= SVt_PV) {
2169 if (dtype == SVt_PVGV) {
2170 SV *sref = SvREFCNT_inc(SvRV(sstr));
2172 int intro = GvINTRO(dstr);
2176 GvGP(dstr)->gp_refcnt--;
2177 GvINTRO_off(dstr); /* one-shot flag */
2178 Newz(602,gp, 1, GP);
2179 GvGP(dstr) = gp_ref(gp);
2180 GvSV(dstr) = NEWSV(72,0);
2181 GvLINE(dstr) = PL_curcop->cop_line;
2182 GvEGV(dstr) = (GV*)dstr;
2185 switch (SvTYPE(sref)) {
2188 SAVESPTR(GvAV(dstr));
2190 dref = (SV*)GvAV(dstr);
2191 GvAV(dstr) = (AV*)sref;
2192 if (PL_curcop->cop_stash != GvSTASH(dstr))
2193 GvIMPORTED_AV_on(dstr);
2197 SAVESPTR(GvHV(dstr));
2199 dref = (SV*)GvHV(dstr);
2200 GvHV(dstr) = (HV*)sref;
2201 if (PL_curcop->cop_stash != GvSTASH(dstr))
2202 GvIMPORTED_HV_on(dstr);
2206 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2207 SvREFCNT_dec(GvCV(dstr));
2208 GvCV(dstr) = Nullcv;
2209 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2210 PL_sub_generation++;
2212 SAVESPTR(GvCV(dstr));
2215 dref = (SV*)GvCV(dstr);
2216 if (GvCV(dstr) != (CV*)sref) {
2217 CV* cv = GvCV(dstr);
2219 if (!GvCVGEN((GV*)dstr) &&
2220 (CvROOT(cv) || CvXSUB(cv)))
2222 SV *const_sv = cv_const_sv(cv);
2223 bool const_changed = TRUE;
2225 const_changed = sv_cmp(const_sv,
2226 op_const_sv(CvSTART((CV*)sref),
2228 /* ahem, death to those who redefine
2229 * active sort subs */
2230 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2231 PL_sortcop == CvSTART(cv))
2233 "Can't redefine active sort subroutine %s",
2234 GvENAME((GV*)dstr));
2235 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2236 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2237 && HvNAME(GvSTASH(CvGV(cv)))
2238 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2240 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2241 "Constant subroutine %s redefined"
2242 : "Subroutine %s redefined",
2243 GvENAME((GV*)dstr));
2246 cv_ckproto(cv, (GV*)dstr,
2247 SvPOK(sref) ? SvPVX(sref) : Nullch);
2249 GvCV(dstr) = (CV*)sref;
2250 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2251 GvASSUMECV_on(dstr);
2252 PL_sub_generation++;
2254 if (PL_curcop->cop_stash != GvSTASH(dstr))
2255 GvIMPORTED_CV_on(dstr);
2259 SAVESPTR(GvIOp(dstr));
2261 dref = (SV*)GvIOp(dstr);
2262 GvIOp(dstr) = (IO*)sref;
2266 SAVESPTR(GvSV(dstr));
2268 dref = (SV*)GvSV(dstr);
2270 if (PL_curcop->cop_stash != GvSTASH(dstr))
2271 GvIMPORTED_SV_on(dstr);
2282 (void)SvOOK_off(dstr); /* backoff */
2284 Safefree(SvPVX(dstr));
2285 SvLEN(dstr)=SvCUR(dstr)=0;
2288 (void)SvOK_off(dstr);
2289 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2291 if (sflags & SVp_NOK) {
2293 SvNVX(dstr) = SvNVX(sstr);
2295 if (sflags & SVp_IOK) {
2296 (void)SvIOK_on(dstr);
2297 SvIVX(dstr) = SvIVX(sstr);
2301 if (SvAMAGIC(sstr)) {
2305 else if (sflags & SVp_POK) {
2308 * Check to see if we can just swipe the string. If so, it's a
2309 * possible small lose on short strings, but a big win on long ones.
2310 * It might even be a win on short strings if SvPVX(dstr)
2311 * has to be allocated and SvPVX(sstr) has to be freed.
2314 if (SvTEMP(sstr) && /* slated for free anyway? */
2315 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2316 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2318 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2320 SvFLAGS(dstr) &= ~SVf_OOK;
2321 Safefree(SvPVX(dstr) - SvIVX(dstr));
2323 else if (SvLEN(dstr))
2324 Safefree(SvPVX(dstr));
2326 (void)SvPOK_only(dstr);
2327 SvPV_set(dstr, SvPVX(sstr));
2328 SvLEN_set(dstr, SvLEN(sstr));
2329 SvCUR_set(dstr, SvCUR(sstr));
2331 (void)SvOK_off(sstr);
2332 SvPV_set(sstr, Nullch);
2337 else { /* have to copy actual string */
2338 STRLEN len = SvCUR(sstr);
2340 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2341 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2342 SvCUR_set(dstr, len);
2343 *SvEND(dstr) = '\0';
2344 (void)SvPOK_only(dstr);
2347 if (sflags & SVp_NOK) {
2349 SvNVX(dstr) = SvNVX(sstr);
2351 if (sflags & SVp_IOK) {
2352 (void)SvIOK_on(dstr);
2353 SvIVX(dstr) = SvIVX(sstr);
2358 else if (sflags & SVp_NOK) {
2359 SvNVX(dstr) = SvNVX(sstr);
2360 (void)SvNOK_only(dstr);
2362 (void)SvIOK_on(dstr);
2363 SvIVX(dstr) = SvIVX(sstr);
2364 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2369 else if (sflags & SVp_IOK) {
2370 (void)SvIOK_only(dstr);
2371 SvIVX(dstr) = SvIVX(sstr);
2376 if (dtype == SVt_PVGV) {
2377 if (ckWARN(WARN_UNSAFE))
2378 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2381 (void)SvOK_off(dstr);
2387 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2389 sv_setsv(dstr,sstr);
2394 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2396 register char *dptr;
2397 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2398 elicit a warning, but it won't hurt. */
2399 SV_CHECK_THINKFIRST(sv);
2404 (void)SvUPGRADE(sv, SVt_PV);
2406 SvGROW(sv, len + 1);
2408 Move(ptr,dptr,len,char);
2411 (void)SvPOK_only(sv); /* validate pointer */
2416 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2418 sv_setpvn(sv,ptr,len);
2423 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2425 register STRLEN len;
2427 SV_CHECK_THINKFIRST(sv);
2433 (void)SvUPGRADE(sv, SVt_PV);
2435 SvGROW(sv, len + 1);
2436 Move(ptr,SvPVX(sv),len+1,char);
2438 (void)SvPOK_only(sv); /* validate pointer */
2443 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2450 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2452 SV_CHECK_THINKFIRST(sv);
2453 (void)SvUPGRADE(sv, SVt_PV);
2458 (void)SvOOK_off(sv);
2459 if (SvPVX(sv) && SvLEN(sv))
2460 Safefree(SvPVX(sv));
2461 Renew(ptr, len+1, char);
2464 SvLEN_set(sv, len+1);
2466 (void)SvPOK_only(sv); /* validate pointer */
2471 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2473 sv_usepvn(sv,ptr,len);
2478 Perl_sv_force_normal(pTHX_ register SV *sv)
2480 if (SvREADONLY(sv)) {
2482 if (PL_curcop != &PL_compiling)
2483 Perl_croak(aTHX_ PL_no_modify);
2487 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2492 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2496 register STRLEN delta;
2498 if (!ptr || !SvPOKp(sv))
2500 SV_CHECK_THINKFIRST(sv);
2501 if (SvTYPE(sv) < SVt_PVIV)
2502 sv_upgrade(sv,SVt_PVIV);
2505 if (!SvLEN(sv)) { /* make copy of shared string */
2506 char *pvx = SvPVX(sv);
2507 STRLEN len = SvCUR(sv);
2508 SvGROW(sv, len + 1);
2509 Move(pvx,SvPVX(sv),len,char);
2513 SvFLAGS(sv) |= SVf_OOK;
2515 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2516 delta = ptr - SvPVX(sv);
2524 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2529 junk = SvPV_force(sv, tlen);
2530 SvGROW(sv, tlen + len + 1);
2533 Move(ptr,SvPVX(sv)+tlen,len,char);
2536 (void)SvPOK_only(sv); /* validate pointer */
2541 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2543 sv_catpvn(sv,ptr,len);
2548 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2554 if (s = SvPV(sstr, len))
2555 sv_catpvn(dstr,s,len);
2559 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2561 sv_catsv(dstr,sstr);
2566 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2568 register STRLEN len;
2574 junk = SvPV_force(sv, tlen);
2576 SvGROW(sv, tlen + len + 1);
2579 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2581 (void)SvPOK_only(sv); /* validate pointer */
2586 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2593 Perl_newSV(pTHX_ STRLEN len)
2599 sv_upgrade(sv, SVt_PV);
2600 SvGROW(sv, len + 1);
2605 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2608 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2612 if (SvREADONLY(sv)) {
2614 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2615 Perl_croak(aTHX_ PL_no_modify);
2617 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2618 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2625 (void)SvUPGRADE(sv, SVt_PVMG);
2627 Newz(702,mg, 1, MAGIC);
2628 mg->mg_moremagic = SvMAGIC(sv);
2631 if (!obj || obj == sv || how == '#' || how == 'r')
2635 mg->mg_obj = SvREFCNT_inc(obj);
2636 mg->mg_flags |= MGf_REFCOUNTED;
2639 mg->mg_len = namlen;
2642 mg->mg_ptr = savepvn(name, namlen);
2643 else if (namlen == HEf_SVKEY)
2644 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2648 mg->mg_virtual = &PL_vtbl_sv;
2651 mg->mg_virtual = &PL_vtbl_amagic;
2654 mg->mg_virtual = &PL_vtbl_amagicelem;
2660 mg->mg_virtual = &PL_vtbl_bm;
2663 mg->mg_virtual = &PL_vtbl_regdata;
2666 mg->mg_virtual = &PL_vtbl_regdatum;
2669 mg->mg_virtual = &PL_vtbl_env;
2672 mg->mg_virtual = &PL_vtbl_fm;
2675 mg->mg_virtual = &PL_vtbl_envelem;
2678 mg->mg_virtual = &PL_vtbl_mglob;
2681 mg->mg_virtual = &PL_vtbl_isa;
2684 mg->mg_virtual = &PL_vtbl_isaelem;
2687 mg->mg_virtual = &PL_vtbl_nkeys;
2694 mg->mg_virtual = &PL_vtbl_dbline;
2698 mg->mg_virtual = &PL_vtbl_mutex;
2700 #endif /* USE_THREADS */
2701 #ifdef USE_LOCALE_COLLATE
2703 mg->mg_virtual = &PL_vtbl_collxfrm;
2705 #endif /* USE_LOCALE_COLLATE */
2707 mg->mg_virtual = &PL_vtbl_pack;
2711 mg->mg_virtual = &PL_vtbl_packelem;
2714 mg->mg_virtual = &PL_vtbl_regexp;
2717 mg->mg_virtual = &PL_vtbl_sig;
2720 mg->mg_virtual = &PL_vtbl_sigelem;
2723 mg->mg_virtual = &PL_vtbl_taint;
2727 mg->mg_virtual = &PL_vtbl_uvar;
2730 mg->mg_virtual = &PL_vtbl_vec;
2733 mg->mg_virtual = &PL_vtbl_substr;
2736 mg->mg_virtual = &PL_vtbl_defelem;
2739 mg->mg_virtual = &PL_vtbl_glob;
2742 mg->mg_virtual = &PL_vtbl_arylen;
2745 mg->mg_virtual = &PL_vtbl_pos;
2748 mg->mg_virtual = &PL_vtbl_backref;
2750 case '~': /* Reserved for use by extensions not perl internals. */
2751 /* Useful for attaching extension internal data to perl vars. */
2752 /* Note that multiple extensions may clash if magical scalars */
2753 /* etc holding private data from one are passed to another. */
2757 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
2761 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2765 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2769 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2772 for (mg = *mgp; mg; mg = *mgp) {
2773 if (mg->mg_type == type) {
2774 MGVTBL* vtbl = mg->mg_virtual;
2775 *mgp = mg->mg_moremagic;
2776 if (vtbl && (vtbl->svt_free != NULL))
2777 (VTBL->svt_free)(aTHX_ sv, mg);
2778 if (mg->mg_ptr && mg->mg_type != 'g')
2779 if (mg->mg_len >= 0)
2780 Safefree(mg->mg_ptr);
2781 else if (mg->mg_len == HEf_SVKEY)
2782 SvREFCNT_dec((SV*)mg->mg_ptr);
2783 if (mg->mg_flags & MGf_REFCOUNTED)
2784 SvREFCNT_dec(mg->mg_obj);
2788 mgp = &mg->mg_moremagic;
2792 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2799 Perl_sv_rvweaken(pTHX_ SV *sv)
2802 if (!SvOK(sv)) /* let undefs pass */
2805 Perl_croak(aTHX_ "Can't weaken a nonreference");
2806 else if (SvWEAKREF(sv)) {
2808 if (ckWARN(WARN_MISC))
2809 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
2813 sv_add_backref(tsv, sv);
2820 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
2824 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2825 av = (AV*)mg->mg_obj;
2828 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2829 SvREFCNT_dec(av); /* for sv_magic */
2835 S_sv_del_backref(pTHX_ SV *sv)
2842 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2843 Perl_croak(aTHX_ "panic: del_backref");
2844 av = (AV *)mg->mg_obj;
2849 svp[i] = &PL_sv_undef; /* XXX */
2856 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2860 register char *midend;
2861 register char *bigend;
2867 Perl_croak(aTHX_ "Can't modify non-existent substring");
2868 SvPV_force(bigstr, curlen);
2869 if (offset + len > curlen) {
2870 SvGROW(bigstr, offset+len+1);
2871 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2872 SvCUR_set(bigstr, offset+len);
2875 i = littlelen - len;
2876 if (i > 0) { /* string might grow */
2877 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2878 mid = big + offset + len;
2879 midend = bigend = big + SvCUR(bigstr);
2882 while (midend > mid) /* shove everything down */
2883 *--bigend = *--midend;
2884 Move(little,big+offset,littlelen,char);
2890 Move(little,SvPVX(bigstr)+offset,len,char);
2895 big = SvPVX(bigstr);
2898 bigend = big + SvCUR(bigstr);
2900 if (midend > bigend)
2901 Perl_croak(aTHX_ "panic: sv_insert");
2903 if (mid - big > bigend - midend) { /* faster to shorten from end */
2905 Move(little, mid, littlelen,char);
2908 i = bigend - midend;
2910 Move(midend, mid, i,char);
2914 SvCUR_set(bigstr, mid - big);
2917 else if (i = mid - big) { /* faster from front */
2918 midend -= littlelen;
2920 sv_chop(bigstr,midend-i);
2925 Move(little, mid, littlelen,char);
2927 else if (littlelen) {
2928 midend -= littlelen;
2929 sv_chop(bigstr,midend);
2930 Move(little,midend,littlelen,char);
2933 sv_chop(bigstr,midend);
2938 /* make sv point to what nstr did */
2941 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2943 U32 refcnt = SvREFCNT(sv);
2944 SV_CHECK_THINKFIRST(sv);
2945 if (SvREFCNT(nsv) != 1)
2946 Perl_warn(aTHX_ "Reference miscount in sv_replace()");
2947 if (SvMAGICAL(sv)) {
2951 sv_upgrade(nsv, SVt_PVMG);
2952 SvMAGIC(nsv) = SvMAGIC(sv);
2953 SvFLAGS(nsv) |= SvMAGICAL(sv);
2959 assert(!SvREFCNT(sv));
2960 StructCopy(nsv,sv,SV);
2961 SvREFCNT(sv) = refcnt;
2962 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2967 Perl_sv_clear(pTHX_ register SV *sv)
2971 assert(SvREFCNT(sv) == 0);
2975 if (PL_defstash) { /* Still have a symbol table? */
2980 Zero(&tmpref, 1, SV);
2981 sv_upgrade(&tmpref, SVt_RV);
2983 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
2984 SvREFCNT(&tmpref) = 1;
2987 stash = SvSTASH(sv);
2988 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2991 PUSHSTACKi(PERLSI_DESTROY);
2992 SvRV(&tmpref) = SvREFCNT_inc(sv);
2997 call_sv((SV*)GvCV(destructor),
2998 G_DISCARD|G_EVAL|G_KEEPERR);
3004 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3006 del_XRV(SvANY(&tmpref));
3009 if (PL_in_clean_objs)
3010 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3012 /* DESTROY gave object new lease on life */
3018 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3019 SvOBJECT_off(sv); /* Curse the object. */
3020 if (SvTYPE(sv) != SVt_PVIO)
3021 --PL_sv_objcount; /* XXX Might want something more general */
3024 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3027 switch (SvTYPE(sv)) {
3030 IoIFP(sv) != PerlIO_stdin() &&
3031 IoIFP(sv) != PerlIO_stdout() &&
3032 IoIFP(sv) != PerlIO_stderr())
3037 PerlDir_close(IoDIRP(sv));
3040 Safefree(IoTOP_NAME(sv));
3041 Safefree(IoFMT_NAME(sv));
3042 Safefree(IoBOTTOM_NAME(sv));
3057 SvREFCNT_dec(LvTARG(sv));
3061 Safefree(GvNAME(sv));
3062 /* cannot decrease stash refcount yet, as we might recursively delete
3063 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3064 of stash until current sv is completely gone.
3065 -- JohnPC, 27 Mar 1998 */
3066 stash = GvSTASH(sv);
3072 (void)SvOOK_off(sv);
3080 SvREFCNT_dec(SvRV(sv));
3082 else if (SvPVX(sv) && SvLEN(sv))
3083 Safefree(SvPVX(sv));
3093 switch (SvTYPE(sv)) {
3109 del_XPVIV(SvANY(sv));
3112 del_XPVNV(SvANY(sv));
3115 del_XPVMG(SvANY(sv));
3118 del_XPVLV(SvANY(sv));
3121 del_XPVAV(SvANY(sv));
3124 del_XPVHV(SvANY(sv));
3127 del_XPVCV(SvANY(sv));
3130 del_XPVGV(SvANY(sv));
3131 /* code duplication for increased performance. */
3132 SvFLAGS(sv) &= SVf_BREAK;
3133 SvFLAGS(sv) |= SVTYPEMASK;
3134 /* decrease refcount of the stash that owns this GV, if any */
3136 SvREFCNT_dec(stash);
3137 return; /* not break, SvFLAGS reset already happened */
3139 del_XPVBM(SvANY(sv));
3142 del_XPVFM(SvANY(sv));
3145 del_XPVIO(SvANY(sv));
3148 SvFLAGS(sv) &= SVf_BREAK;
3149 SvFLAGS(sv) |= SVTYPEMASK;
3153 Perl_sv_newref(pTHX_ SV *sv)
3156 ATOMIC_INC(SvREFCNT(sv));
3161 Perl_sv_free(pTHX_ SV *sv)
3163 int refcount_is_zero;
3167 if (SvREFCNT(sv) == 0) {
3168 if (SvFLAGS(sv) & SVf_BREAK)
3170 if (PL_in_clean_all) /* All is fair */
3172 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3173 /* make sure SvREFCNT(sv)==0 happens very seldom */
3174 SvREFCNT(sv) = (~(U32)0)/2;
3177 Perl_warn(aTHX_ "Attempt to free unreferenced scalar");
3180 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3181 if (!refcount_is_zero)
3185 Perl_warn(aTHX_ "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3189 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3190 /* make sure SvREFCNT(sv)==0 happens very seldom */
3191 SvREFCNT(sv) = (~(U32)0)/2;
3200 Perl_sv_len(pTHX_ register SV *sv)
3209 len = mg_length(sv);
3211 junk = SvPV(sv, len);
3216 Perl_sv_len_utf8(pTHX_ register SV *sv)
3227 len = mg_length(sv);
3230 s = (U8*)SvPV(sv, len);
3241 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3246 I32 uoffset = *offsetp;
3252 start = s = (U8*)SvPV(sv, len);
3254 while (s < send && uoffset--)
3258 *offsetp = s - start;
3262 while (s < send && ulen--)
3272 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3281 s = (U8*)SvPV(sv, len);
3283 Perl_croak(aTHX_ "panic: bad byte offset");
3284 send = s + *offsetp;
3291 Perl_warn(aTHX_ "Malformed UTF-8 character");
3299 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3311 pv1 = SvPV(str1, cur1);
3316 pv2 = SvPV(str2, cur2);
3321 return memEQ(pv1, pv2, cur1);
3325 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3328 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3330 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3334 return cur2 ? -1 : 0;
3339 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3342 return retval < 0 ? -1 : 1;
3347 return cur1 < cur2 ? -1 : 1;
3351 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3353 #ifdef USE_LOCALE_COLLATE
3359 if (PL_collation_standard)
3363 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3365 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3367 if (!pv1 || !len1) {
3378 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3381 return retval < 0 ? -1 : 1;
3384 * When the result of collation is equality, that doesn't mean
3385 * that there are no differences -- some locales exclude some
3386 * characters from consideration. So to avoid false equalities,
3387 * we use the raw string as a tiebreaker.
3393 #endif /* USE_LOCALE_COLLATE */
3395 return sv_cmp(sv1, sv2);
3398 #ifdef USE_LOCALE_COLLATE
3400 * Any scalar variable may carry an 'o' magic that contains the
3401 * scalar data of the variable transformed to such a format that
3402 * a normal memory comparison can be used to compare the data
3403 * according to the locale settings.
3406 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3410 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3411 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3416 Safefree(mg->mg_ptr);
3418 if ((xf = mem_collxfrm(s, len, &xlen))) {
3419 if (SvREADONLY(sv)) {
3422 return xf + sizeof(PL_collation_ix);
3425 sv_magic(sv, 0, 'o', 0, 0);
3426 mg = mg_find(sv, 'o');
3439 if (mg && mg->mg_ptr) {
3441 return mg->mg_ptr + sizeof(PL_collation_ix);
3449 #endif /* USE_LOCALE_COLLATE */
3452 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3457 register STDCHAR rslast;
3458 register STDCHAR *bp;
3462 SV_CHECK_THINKFIRST(sv);
3463 (void)SvUPGRADE(sv, SVt_PV);
3467 if (RsSNARF(PL_rs)) {
3471 else if (RsRECORD(PL_rs)) {
3472 I32 recsize, bytesread;
3475 /* Grab the size of the record we're getting */
3476 recsize = SvIV(SvRV(PL_rs));
3477 (void)SvPOK_only(sv); /* Validate pointer */
3478 buffer = SvGROW(sv, recsize + 1);
3481 /* VMS wants read instead of fread, because fread doesn't respect */
3482 /* RMS record boundaries. This is not necessarily a good thing to be */
3483 /* doing, but we've got no other real choice */
3484 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3486 bytesread = PerlIO_read(fp, buffer, recsize);
3488 SvCUR_set(sv, bytesread);
3489 buffer[bytesread] = '\0';
3490 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3492 else if (RsPARA(PL_rs)) {
3497 rsptr = SvPV(PL_rs, rslen);
3498 rslast = rslen ? rsptr[rslen - 1] : '\0';
3500 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3501 do { /* to make sure file boundaries work right */
3504 i = PerlIO_getc(fp);
3508 PerlIO_ungetc(fp,i);
3514 /* See if we know enough about I/O mechanism to cheat it ! */
3516 /* This used to be #ifdef test - it is made run-time test for ease
3517 of abstracting out stdio interface. One call should be cheap
3518 enough here - and may even be a macro allowing compile
3522 if (PerlIO_fast_gets(fp)) {
3525 * We're going to steal some values from the stdio struct
3526 * and put EVERYTHING in the innermost loop into registers.
3528 register STDCHAR *ptr;
3532 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3533 /* An ungetc()d char is handled separately from the regular
3534 * buffer, so we getc() it back out and stuff it in the buffer.
3536 i = PerlIO_getc(fp);
3537 if (i == EOF) return 0;
3538 *(--((*fp)->_ptr)) = (unsigned char) i;
3542 /* Here is some breathtakingly efficient cheating */
3544 cnt = PerlIO_get_cnt(fp); /* get count into register */
3545 (void)SvPOK_only(sv); /* validate pointer */
3546 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3547 if (cnt > 80 && SvLEN(sv) > append) {
3548 shortbuffered = cnt - SvLEN(sv) + append + 1;
3549 cnt -= shortbuffered;
3553 /* remember that cnt can be negative */
3554 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3559 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3560 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3561 DEBUG_P(PerlIO_printf(Perl_debug_log,
3562 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3563 DEBUG_P(PerlIO_printf(Perl_debug_log,
3564 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3565 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3566 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3571 while (cnt > 0) { /* this | eat */
3573 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3574 goto thats_all_folks; /* screams | sed :-) */
3578 Copy(ptr, bp, cnt, char); /* this | eat */
3579 bp += cnt; /* screams | dust */
3580 ptr += cnt; /* louder | sed :-) */
3585 if (shortbuffered) { /* oh well, must extend */
3586 cnt = shortbuffered;
3588 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3590 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3591 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3595 DEBUG_P(PerlIO_printf(Perl_debug_log,
3596 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3597 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3598 DEBUG_P(PerlIO_printf(Perl_debug_log,
3599 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3600 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3601 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3602 /* This used to call 'filbuf' in stdio form, but as that behaves like
3603 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3604 another abstraction. */
3605 i = PerlIO_getc(fp); /* get more characters */
3606 DEBUG_P(PerlIO_printf(Perl_debug_log,
3607 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3608 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3609 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3610 cnt = PerlIO_get_cnt(fp);
3611 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3612 DEBUG_P(PerlIO_printf(Perl_debug_log,
3613 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3615 if (i == EOF) /* all done for ever? */
3616 goto thats_really_all_folks;
3618 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3620 SvGROW(sv, bpx + cnt + 2);
3621 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3623 *bp++ = i; /* store character from PerlIO_getc */
3625 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3626 goto thats_all_folks;
3630 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3631 memNE((char*)bp - rslen, rsptr, rslen))
3632 goto screamer; /* go back to the fray */
3633 thats_really_all_folks:
3635 cnt += shortbuffered;
3636 DEBUG_P(PerlIO_printf(Perl_debug_log,
3637 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3638 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3639 DEBUG_P(PerlIO_printf(Perl_debug_log,
3640 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3641 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3642 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3644 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3645 DEBUG_P(PerlIO_printf(Perl_debug_log,
3646 "Screamer: done, len=%ld, string=|%.*s|\n",
3647 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3651 /*The big, slow, and stupid way */
3656 register STDCHAR *bpe = buf + sizeof(buf);
3658 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3659 ; /* keep reading */
3663 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3664 /* Accomodate broken VAXC compiler, which applies U8 cast to
3665 * both args of ?: operator, causing EOF to change into 255
3667 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3671 sv_catpvn(sv, (char *) buf, cnt);
3673 sv_setpvn(sv, (char *) buf, cnt);
3675 if (i != EOF && /* joy */
3677 SvCUR(sv) < rslen ||
3678 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3682 * If we're reading from a TTY and we get a short read,
3683 * indicating that the user hit his EOF character, we need
3684 * to notice it now, because if we try to read from the TTY
3685 * again, the EOF condition will disappear.
3687 * The comparison of cnt to sizeof(buf) is an optimization
3688 * that prevents unnecessary calls to feof().
3692 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3697 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3698 while (i != EOF) { /* to make sure file boundaries work right */
3699 i = PerlIO_getc(fp);
3701 PerlIO_ungetc(fp,i);
3708 win32_strip_return(sv);
3711 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3716 Perl_sv_inc(pTHX_ register SV *sv)
3725 if (SvTHINKFIRST(sv)) {
3726 if (SvREADONLY(sv)) {
3728 if (PL_curcop != &PL_compiling)
3729 Perl_croak(aTHX_ PL_no_modify);
3733 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3740 flags = SvFLAGS(sv);
3741 if (flags & SVp_NOK) {
3742 (void)SvNOK_only(sv);
3746 if (flags & SVp_IOK) {
3748 if (SvUVX(sv) == UV_MAX)
3749 sv_setnv(sv, (double)UV_MAX + 1.0);
3751 (void)SvIOK_only_UV(sv);
3754 if (SvIVX(sv) == IV_MAX)
3755 sv_setnv(sv, (double)IV_MAX + 1.0);
3757 (void)SvIOK_only(sv);
3763 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3764 if ((flags & SVTYPEMASK) < SVt_PVNV)
3765 sv_upgrade(sv, SVt_NV);
3767 (void)SvNOK_only(sv);
3771 while (isALPHA(*d)) d++;
3772 while (isDIGIT(*d)) d++;
3774 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
3778 while (d >= SvPVX(sv)) {
3786 /* MKS: The original code here died if letters weren't consecutive.
3787 * at least it didn't have to worry about non-C locales. The
3788 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3789 * arranged in order (although not consecutively) and that only
3790 * [A-Za-z] are accepted by isALPHA in the C locale.
3792 if (*d != 'z' && *d != 'Z') {
3793 do { ++*d; } while (!isALPHA(*d));
3796 *(d--) -= 'z' - 'a';
3801 *(d--) -= 'z' - 'a' + 1;
3805 /* oh,oh, the number grew */
3806 SvGROW(sv, SvCUR(sv) + 2);
3808 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3817 Perl_sv_dec(pTHX_ register SV *sv)
3825 if (SvTHINKFIRST(sv)) {
3826 if (SvREADONLY(sv)) {
3828 if (PL_curcop != &PL_compiling)
3829 Perl_croak(aTHX_ PL_no_modify);
3833 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3840 flags = SvFLAGS(sv);
3841 if (flags & SVp_NOK) {
3843 (void)SvNOK_only(sv);
3846 if (flags & SVp_IOK) {
3848 if (SvUVX(sv) == 0) {
3849 (void)SvIOK_only(sv);
3853 (void)SvIOK_only_UV(sv);
3857 if (SvIVX(sv) == IV_MIN)
3858 sv_setnv(sv, (double)IV_MIN - 1.0);
3860 (void)SvIOK_only(sv);
3866 if (!(flags & SVp_POK)) {
3867 if ((flags & SVTYPEMASK) < SVt_PVNV)
3868 sv_upgrade(sv, SVt_NV);
3870 (void)SvNOK_only(sv);
3873 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
3876 /* Make a string that will exist for the duration of the expression
3877 * evaluation. Actually, it may have to last longer than that, but
3878 * hopefully we won't free it until it has been assigned to a
3879 * permanent location. */
3882 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3888 sv_setsv(sv,oldstr);
3890 PL_tmps_stack[++PL_tmps_ix] = sv;
3896 Perl_sv_newmortal(pTHX)
3902 SvFLAGS(sv) = SVs_TEMP;
3904 PL_tmps_stack[++PL_tmps_ix] = sv;
3908 /* same thing without the copying */
3911 Perl_sv_2mortal(pTHX_ register SV *sv)
3916 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3919 PL_tmps_stack[++PL_tmps_ix] = sv;
3925 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3932 sv_setpvn(sv,s,len);
3937 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3942 sv_setpvn(sv,s,len);
3946 #if defined(PERL_IMPLICIT_CONTEXT)
3948 Perl_newSVpvf_nocontext(const char* pat, ...)
3955 va_start(args, pat);
3956 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3963 Perl_newSVpvf(pTHX_ const char* pat, ...)
3969 va_start(args, pat);
3970 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3976 Perl_newSVnv(pTHX_ double n)
3986 Perl_newSViv(pTHX_ IV i)
3996 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4002 sv_upgrade(sv, SVt_RV);
4010 Perl_newRV(pTHX_ SV *tmpRef)
4012 return newRV_noinc(SvREFCNT_inc(tmpRef));
4015 /* make an exact duplicate of old */
4018 Perl_newSVsv(pTHX_ register SV *old)
4024 if (SvTYPE(old) == SVTYPEMASK) {
4025 Perl_warn(aTHX_ "semi-panic: attempt to dup freed string");
4040 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4053 if (!*s) { /* reset ?? searches */
4054 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4055 pm->op_pmdynflags &= ~PMdf_USED;
4060 /* reset variables */
4062 if (!HvARRAY(stash))
4065 Zero(todo, 256, char);
4072 for ( ; i <= max; i++) {
4075 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4076 for (entry = HvARRAY(stash)[i];
4078 entry = HeNEXT(entry))
4080 if (!todo[(U8)*HeKEY(entry)])
4082 gv = (GV*)HeVAL(entry);
4084 if (SvTHINKFIRST(sv)) {
4085 if (!SvREADONLY(sv) && SvROK(sv))
4090 if (SvTYPE(sv) >= SVt_PV) {
4092 if (SvPVX(sv) != Nullch)
4099 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4101 #ifndef VMS /* VMS has no environ array */
4103 environ[0] = Nullch;
4112 Perl_sv_2io(pTHX_ SV *sv)
4118 switch (SvTYPE(sv)) {
4126 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4130 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4132 return sv_2io(SvRV(sv));
4133 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4139 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4146 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4153 return *gvp = Nullgv, Nullcv;
4154 switch (SvTYPE(sv)) {
4174 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4175 tryAMAGICunDEREF(to_cv);
4178 if (SvTYPE(sv) == SVt_PVCV) {
4187 Perl_croak(aTHX_ "Not a subroutine reference");
4192 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4198 if (lref && !GvCVu(gv)) {
4201 tmpsv = NEWSV(704,0);
4202 gv_efullname3(tmpsv, gv, Nullch);
4203 /* XXX this is probably not what they think they're getting.
4204 * It has the same effect as "sub name;", i.e. just a forward
4206 newSUB(start_subparse(FALSE, 0),
4207 newSVOP(OP_CONST, 0, tmpsv),
4212 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4219 Perl_sv_true(pTHX_ register SV *sv)
4226 if ((tXpv = (XPV*)SvANY(sv)) &&
4227 (*tXpv->xpv_pv > '0' ||
4228 tXpv->xpv_cur > 1 ||
4229 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4236 return SvIVX(sv) != 0;
4239 return SvNVX(sv) != 0.0;
4241 return sv_2bool(sv);
4247 Perl_sv_iv(pTHX_ register SV *sv)
4251 return (IV)SvUVX(sv);
4258 Perl_sv_uv(pTHX_ register SV *sv)
4263 return (UV)SvIVX(sv);
4269 Perl_sv_nv(pTHX_ register SV *sv)
4277 Perl_sv_pv(pTHX_ SV *sv)
4284 return sv_2pv(sv, &n_a);
4288 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4294 return sv_2pv(sv, lp);
4298 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4302 if (SvTHINKFIRST(sv) && !SvROK(sv))
4303 sv_force_normal(sv);
4309 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4311 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4312 PL_op_name[PL_op->op_type]);
4316 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4321 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4322 SvGROW(sv, len + 1);
4323 Move(s,SvPVX(sv),len,char);
4328 SvPOK_on(sv); /* validate pointer */
4330 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4331 (unsigned long)sv,SvPVX(sv)));
4338 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4340 if (ob && SvOBJECT(sv))
4341 return HvNAME(SvSTASH(sv));
4343 switch (SvTYPE(sv)) {
4357 case SVt_PVLV: return "LVALUE";
4358 case SVt_PVAV: return "ARRAY";
4359 case SVt_PVHV: return "HASH";
4360 case SVt_PVCV: return "CODE";
4361 case SVt_PVGV: return "GLOB";
4362 case SVt_PVFM: return "FORMAT";
4363 default: return "UNKNOWN";
4369 Perl_sv_isobject(pTHX_ SV *sv)
4384 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4396 return strEQ(HvNAME(SvSTASH(sv)), name);
4400 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4407 SV_CHECK_THINKFIRST(rv);
4410 if (SvTYPE(rv) < SVt_RV)
4411 sv_upgrade(rv, SVt_RV);
4418 HV* stash = gv_stashpv(classname, TRUE);
4419 (void)sv_bless(rv, stash);
4425 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4428 sv_setsv(rv, &PL_sv_undef);
4432 sv_setiv(newSVrv(rv,classname), (IV)pv);
4437 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4439 sv_setiv(newSVrv(rv,classname), iv);
4444 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, double nv)
4446 sv_setnv(newSVrv(rv,classname), nv);
4451 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4453 sv_setpvn(newSVrv(rv,classname), pv, n);
4458 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4463 Perl_croak(aTHX_ "Can't bless non-reference value");
4465 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4466 if (SvREADONLY(tmpRef))
4467 Perl_croak(aTHX_ PL_no_modify);
4468 if (SvOBJECT(tmpRef)) {
4469 if (SvTYPE(tmpRef) != SVt_PVIO)
4471 SvREFCNT_dec(SvSTASH(tmpRef));
4474 SvOBJECT_on(tmpRef);
4475 if (SvTYPE(tmpRef) != SVt_PVIO)
4477 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4478 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4489 S_sv_unglob(pTHX_ SV *sv)
4491 assert(SvTYPE(sv) == SVt_PVGV);
4496 SvREFCNT_dec(GvSTASH(sv));
4497 GvSTASH(sv) = Nullhv;
4499 sv_unmagic(sv, '*');
4500 Safefree(GvNAME(sv));
4502 SvFLAGS(sv) &= ~SVTYPEMASK;
4503 SvFLAGS(sv) |= SVt_PVMG;
4507 Perl_sv_unref(pTHX_ SV *sv)
4511 if (SvWEAKREF(sv)) {
4519 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4522 sv_2mortal(rv); /* Schedule for freeing later */
4526 Perl_sv_taint(pTHX_ SV *sv)
4528 sv_magic((sv), Nullsv, 't', Nullch, 0);
4532 Perl_sv_untaint(pTHX_ SV *sv)
4534 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4535 MAGIC *mg = mg_find(sv, 't');
4542 Perl_sv_tainted(pTHX_ SV *sv)
4544 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4545 MAGIC *mg = mg_find(sv, 't');
4546 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4553 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4555 char buf[TYPE_CHARS(UV)];
4557 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4559 sv_setpvn(sv, ptr, ebuf - ptr);
4564 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4566 char buf[TYPE_CHARS(UV)];
4568 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4570 sv_setpvn(sv, ptr, ebuf - ptr);
4574 #if defined(PERL_IMPLICIT_CONTEXT)
4576 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4580 va_start(args, pat);
4581 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4587 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4591 va_start(args, pat);
4592 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4599 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4602 va_start(args, pat);
4603 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4609 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4612 va_start(args, pat);
4613 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4618 #if defined(PERL_IMPLICIT_CONTEXT)
4620 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4624 va_start(args, pat);
4625 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4630 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4634 va_start(args, pat);
4635 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4642 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4645 va_start(args, pat);
4646 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4651 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4654 va_start(args, pat);
4655 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4661 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4663 sv_setpvn(sv, "", 0);
4664 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4668 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4676 static char nullstr[] = "(null)";
4678 /* no matter what, this is a string now */
4679 (void)SvPV_force(sv, origlen);
4681 /* special-case "", "%s", and "%_" */
4684 if (patlen == 2 && pat[0] == '%') {
4688 char *s = va_arg(*args, char*);
4689 sv_catpv(sv, s ? s : nullstr);
4691 else if (svix < svmax)
4692 sv_catsv(sv, *svargs);
4696 sv_catsv(sv, va_arg(*args, SV*));
4699 /* See comment on '_' below */
4704 patend = (char*)pat + patlen;
4705 for (p = (char*)pat; p < patend; p = q) {
4713 bool has_precis = FALSE;
4718 STRLEN esignlen = 0;
4720 char *eptr = Nullch;
4722 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4733 for (q = p; q < patend && *q != '%'; ++q) ;
4735 sv_catpvn(sv, p, q - p);
4773 case '1': case '2': case '3':
4774 case '4': case '5': case '6':
4775 case '7': case '8': case '9':
4778 width = width * 10 + (*q++ - '0');
4783 i = va_arg(*args, int);
4785 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4787 width = (i < 0) ? -i : i;
4798 i = va_arg(*args, int);
4800 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4801 precis = (i < 0) ? 0 : i;
4807 precis = precis * 10 + (*q++ - '0');
4816 #if 0 /* when quads have better support within Perl */
4817 if (*(q + 1) == 'l') {
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;
4917 case 'h': iv = (short)va_arg(*args, int); break;
4918 default: iv = va_arg(*args, int); break;
4919 case 'l': iv = va_arg(*args, long); break;
4920 case 'V': iv = va_arg(*args, IV); break;
4924 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4926 case 'h': iv = (short)iv; break;
4927 default: iv = (int)iv; break;
4928 case 'l': iv = (long)iv; break;
4935 esignbuf[esignlen++] = plus;
4939 esignbuf[esignlen++] = '-';
4969 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4970 default: uv = va_arg(*args, unsigned); break;
4971 case 'l': uv = va_arg(*args, unsigned long); break;
4972 case 'V': uv = va_arg(*args, UV); break;
4976 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4978 case 'h': uv = (unsigned short)uv; break;
4979 default: uv = (unsigned)uv; break;
4980 case 'l': uv = (unsigned long)uv; break;
4986 eptr = ebuf + sizeof ebuf;
4992 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
4998 esignbuf[esignlen++] = '0';
4999 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5005 *--eptr = '0' + dig;
5007 if (alt && *eptr != '0')
5013 *--eptr = '0' + dig;
5015 if (alt && *eptr != '0')
5018 default: /* it had better be ten or less */
5021 *--eptr = '0' + dig;
5022 } while (uv /= base);
5025 elen = (ebuf + sizeof ebuf) - eptr;
5028 zeros = precis - elen;
5029 else if (precis == 0 && elen == 1 && *eptr == '0')
5034 /* FLOATING POINT */
5037 c = 'f'; /* maybe %F isn't supported here */
5043 /* This is evil, but floating point is even more evil */
5046 nv = va_arg(*args, double);
5048 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5051 if (c != 'e' && c != 'E') {
5053 (void)frexp(nv, &i);
5054 if (i == PERL_INT_MIN)
5055 Perl_die(aTHX_ "panic: frexp");
5057 need = BIT_DIGITS(i);
5059 need += has_precis ? precis : 6; /* known default */
5063 need += 20; /* fudge factor */
5064 if (PL_efloatsize < need) {
5065 Safefree(PL_efloatbuf);
5066 PL_efloatsize = need + 20; /* more fudge */
5067 New(906, PL_efloatbuf, PL_efloatsize, char);
5070 eptr = ebuf + sizeof ebuf;
5075 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5080 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5093 RESTORE_NUMERIC_STANDARD();
5094 (void)sprintf(PL_efloatbuf, eptr, nv);
5095 RESTORE_NUMERIC_LOCAL();
5098 eptr = PL_efloatbuf;
5099 elen = strlen(PL_efloatbuf);
5103 * User-defined locales may include arbitrary characters.
5104 * And, unfortunately, some system may alloc the "C" locale
5105 * to be overridden by a malicious user.
5108 *used_locale = TRUE;
5109 #endif /* LC_NUMERIC */
5116 i = SvCUR(sv) - origlen;
5119 case 'h': *(va_arg(*args, short*)) = i; break;
5120 default: *(va_arg(*args, int*)) = i; break;
5121 case 'l': *(va_arg(*args, long*)) = i; break;
5122 case 'V': *(va_arg(*args, IV*)) = i; break;
5125 else if (svix < svmax)
5126 sv_setuv(svargs[svix++], (UV)i);
5127 continue; /* not "break" */
5133 if (!args && ckWARN(WARN_PRINTF) &&
5134 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5135 SV *msg = sv_newmortal();
5136 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5137 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5139 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5142 sv_catpv(msg, "end of string");
5143 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5146 /* output mangled stuff ... */
5152 /* ... right here, because formatting flags should not apply */
5153 SvGROW(sv, SvCUR(sv) + elen + 1);
5155 memcpy(p, eptr, elen);
5158 SvCUR(sv) = p - SvPVX(sv);
5159 continue; /* not "break" */
5162 have = esignlen + zeros + elen;
5163 need = (have > width ? have : width);
5166 SvGROW(sv, SvCUR(sv) + need + 1);
5168 if (esignlen && fill == '0') {
5169 for (i = 0; i < esignlen; i++)
5173 memset(p, fill, gap);
5176 if (esignlen && fill != '0') {
5177 for (i = 0; i < esignlen; i++)
5181 for (i = zeros; i; i--)
5185 memcpy(p, eptr, elen);
5189 memset(p, ' ', gap);
5193 SvCUR(sv) = p - SvPVX(sv);