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)));
3652 /*The big, slow, and stupid way */
3655 /* Need to work around EPOC SDK features */
3656 /* On WINS: MS VC5 generates calls to _chkstk, */
3657 /* if a `large' stack frame is allocated */
3658 /* gcc on MARM does not generate calls like these */
3664 register STDCHAR *bpe = buf + sizeof(buf);
3666 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3667 ; /* keep reading */
3671 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3672 /* Accomodate broken VAXC compiler, which applies U8 cast to
3673 * both args of ?: operator, causing EOF to change into 255
3675 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3679 sv_catpvn(sv, (char *) buf, cnt);
3681 sv_setpvn(sv, (char *) buf, cnt);
3683 if (i != EOF && /* joy */
3685 SvCUR(sv) < rslen ||
3686 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3690 * If we're reading from a TTY and we get a short read,
3691 * indicating that the user hit his EOF character, we need
3692 * to notice it now, because if we try to read from the TTY
3693 * again, the EOF condition will disappear.
3695 * The comparison of cnt to sizeof(buf) is an optimization
3696 * that prevents unnecessary calls to feof().
3700 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3705 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3706 while (i != EOF) { /* to make sure file boundaries work right */
3707 i = PerlIO_getc(fp);
3709 PerlIO_ungetc(fp,i);
3716 win32_strip_return(sv);
3719 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3724 Perl_sv_inc(pTHX_ register SV *sv)
3733 if (SvTHINKFIRST(sv)) {
3734 if (SvREADONLY(sv)) {
3736 if (PL_curcop != &PL_compiling)
3737 Perl_croak(aTHX_ PL_no_modify);
3741 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3748 flags = SvFLAGS(sv);
3749 if (flags & SVp_NOK) {
3750 (void)SvNOK_only(sv);
3754 if (flags & SVp_IOK) {
3756 if (SvUVX(sv) == UV_MAX)
3757 sv_setnv(sv, (double)UV_MAX + 1.0);
3759 (void)SvIOK_only_UV(sv);
3762 if (SvIVX(sv) == IV_MAX)
3763 sv_setnv(sv, (double)IV_MAX + 1.0);
3765 (void)SvIOK_only(sv);
3771 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3772 if ((flags & SVTYPEMASK) < SVt_PVNV)
3773 sv_upgrade(sv, SVt_NV);
3775 (void)SvNOK_only(sv);
3779 while (isALPHA(*d)) d++;
3780 while (isDIGIT(*d)) d++;
3782 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
3786 while (d >= SvPVX(sv)) {
3794 /* MKS: The original code here died if letters weren't consecutive.
3795 * at least it didn't have to worry about non-C locales. The
3796 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3797 * arranged in order (although not consecutively) and that only
3798 * [A-Za-z] are accepted by isALPHA in the C locale.
3800 if (*d != 'z' && *d != 'Z') {
3801 do { ++*d; } while (!isALPHA(*d));
3804 *(d--) -= 'z' - 'a';
3809 *(d--) -= 'z' - 'a' + 1;
3813 /* oh,oh, the number grew */
3814 SvGROW(sv, SvCUR(sv) + 2);
3816 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3825 Perl_sv_dec(pTHX_ register SV *sv)
3833 if (SvTHINKFIRST(sv)) {
3834 if (SvREADONLY(sv)) {
3836 if (PL_curcop != &PL_compiling)
3837 Perl_croak(aTHX_ PL_no_modify);
3841 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3848 flags = SvFLAGS(sv);
3849 if (flags & SVp_NOK) {
3851 (void)SvNOK_only(sv);
3854 if (flags & SVp_IOK) {
3856 if (SvUVX(sv) == 0) {
3857 (void)SvIOK_only(sv);
3861 (void)SvIOK_only_UV(sv);
3865 if (SvIVX(sv) == IV_MIN)
3866 sv_setnv(sv, (double)IV_MIN - 1.0);
3868 (void)SvIOK_only(sv);
3874 if (!(flags & SVp_POK)) {
3875 if ((flags & SVTYPEMASK) < SVt_PVNV)
3876 sv_upgrade(sv, SVt_NV);
3878 (void)SvNOK_only(sv);
3881 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
3884 /* Make a string that will exist for the duration of the expression
3885 * evaluation. Actually, it may have to last longer than that, but
3886 * hopefully we won't free it until it has been assigned to a
3887 * permanent location. */
3890 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3896 sv_setsv(sv,oldstr);
3898 PL_tmps_stack[++PL_tmps_ix] = sv;
3904 Perl_sv_newmortal(pTHX)
3910 SvFLAGS(sv) = SVs_TEMP;
3912 PL_tmps_stack[++PL_tmps_ix] = sv;
3916 /* same thing without the copying */
3919 Perl_sv_2mortal(pTHX_ register SV *sv)
3924 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3927 PL_tmps_stack[++PL_tmps_ix] = sv;
3933 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3940 sv_setpvn(sv,s,len);
3945 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3950 sv_setpvn(sv,s,len);
3954 #if defined(PERL_IMPLICIT_CONTEXT)
3956 Perl_newSVpvf_nocontext(const char* pat, ...)
3963 va_start(args, pat);
3964 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3971 Perl_newSVpvf(pTHX_ const char* pat, ...)
3977 va_start(args, pat);
3978 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3984 Perl_newSVnv(pTHX_ double n)
3994 Perl_newSViv(pTHX_ IV i)
4004 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4010 sv_upgrade(sv, SVt_RV);
4018 Perl_newRV(pTHX_ SV *tmpRef)
4020 return newRV_noinc(SvREFCNT_inc(tmpRef));
4023 /* make an exact duplicate of old */
4026 Perl_newSVsv(pTHX_ register SV *old)
4032 if (SvTYPE(old) == SVTYPEMASK) {
4033 Perl_warn(aTHX_ "semi-panic: attempt to dup freed string");
4048 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4061 if (!*s) { /* reset ?? searches */
4062 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4063 pm->op_pmdynflags &= ~PMdf_USED;
4068 /* reset variables */
4070 if (!HvARRAY(stash))
4073 Zero(todo, 256, char);
4080 for ( ; i <= max; i++) {
4083 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4084 for (entry = HvARRAY(stash)[i];
4086 entry = HeNEXT(entry))
4088 if (!todo[(U8)*HeKEY(entry)])
4090 gv = (GV*)HeVAL(entry);
4092 if (SvTHINKFIRST(sv)) {
4093 if (!SvREADONLY(sv) && SvROK(sv))
4098 if (SvTYPE(sv) >= SVt_PV) {
4100 if (SvPVX(sv) != Nullch)
4107 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4109 #ifndef VMS /* VMS has no environ array */
4111 environ[0] = Nullch;
4120 Perl_sv_2io(pTHX_ SV *sv)
4126 switch (SvTYPE(sv)) {
4134 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4138 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4140 return sv_2io(SvRV(sv));
4141 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4147 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4154 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4161 return *gvp = Nullgv, Nullcv;
4162 switch (SvTYPE(sv)) {
4182 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4183 tryAMAGICunDEREF(to_cv);
4186 if (SvTYPE(sv) == SVt_PVCV) {
4195 Perl_croak(aTHX_ "Not a subroutine reference");
4200 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4206 if (lref && !GvCVu(gv)) {
4209 tmpsv = NEWSV(704,0);
4210 gv_efullname3(tmpsv, gv, Nullch);
4211 /* XXX this is probably not what they think they're getting.
4212 * It has the same effect as "sub name;", i.e. just a forward
4214 newSUB(start_subparse(FALSE, 0),
4215 newSVOP(OP_CONST, 0, tmpsv),
4220 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4227 Perl_sv_true(pTHX_ register SV *sv)
4234 if ((tXpv = (XPV*)SvANY(sv)) &&
4235 (*tXpv->xpv_pv > '0' ||
4236 tXpv->xpv_cur > 1 ||
4237 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4244 return SvIVX(sv) != 0;
4247 return SvNVX(sv) != 0.0;
4249 return sv_2bool(sv);
4255 Perl_sv_iv(pTHX_ register SV *sv)
4259 return (IV)SvUVX(sv);
4266 Perl_sv_uv(pTHX_ register SV *sv)
4271 return (UV)SvIVX(sv);
4277 Perl_sv_nv(pTHX_ register SV *sv)
4285 Perl_sv_pv(pTHX_ SV *sv)
4292 return sv_2pv(sv, &n_a);
4296 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4302 return sv_2pv(sv, lp);
4306 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4310 if (SvTHINKFIRST(sv) && !SvROK(sv))
4311 sv_force_normal(sv);
4317 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4319 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4320 PL_op_name[PL_op->op_type]);
4324 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4329 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4330 SvGROW(sv, len + 1);
4331 Move(s,SvPVX(sv),len,char);
4336 SvPOK_on(sv); /* validate pointer */
4338 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4339 (unsigned long)sv,SvPVX(sv)));
4346 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4348 if (ob && SvOBJECT(sv))
4349 return HvNAME(SvSTASH(sv));
4351 switch (SvTYPE(sv)) {
4365 case SVt_PVLV: return "LVALUE";
4366 case SVt_PVAV: return "ARRAY";
4367 case SVt_PVHV: return "HASH";
4368 case SVt_PVCV: return "CODE";
4369 case SVt_PVGV: return "GLOB";
4370 case SVt_PVFM: return "FORMAT";
4371 default: return "UNKNOWN";
4377 Perl_sv_isobject(pTHX_ SV *sv)
4392 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4404 return strEQ(HvNAME(SvSTASH(sv)), name);
4408 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4415 SV_CHECK_THINKFIRST(rv);
4418 if (SvTYPE(rv) < SVt_RV)
4419 sv_upgrade(rv, SVt_RV);
4426 HV* stash = gv_stashpv(classname, TRUE);
4427 (void)sv_bless(rv, stash);
4433 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4436 sv_setsv(rv, &PL_sv_undef);
4440 sv_setiv(newSVrv(rv,classname), (IV)pv);
4445 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4447 sv_setiv(newSVrv(rv,classname), iv);
4452 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, double nv)
4454 sv_setnv(newSVrv(rv,classname), nv);
4459 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4461 sv_setpvn(newSVrv(rv,classname), pv, n);
4466 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4471 Perl_croak(aTHX_ "Can't bless non-reference value");
4473 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4474 if (SvREADONLY(tmpRef))
4475 Perl_croak(aTHX_ PL_no_modify);
4476 if (SvOBJECT(tmpRef)) {
4477 if (SvTYPE(tmpRef) != SVt_PVIO)
4479 SvREFCNT_dec(SvSTASH(tmpRef));
4482 SvOBJECT_on(tmpRef);
4483 if (SvTYPE(tmpRef) != SVt_PVIO)
4485 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4486 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4497 S_sv_unglob(pTHX_ SV *sv)
4499 assert(SvTYPE(sv) == SVt_PVGV);
4504 SvREFCNT_dec(GvSTASH(sv));
4505 GvSTASH(sv) = Nullhv;
4507 sv_unmagic(sv, '*');
4508 Safefree(GvNAME(sv));
4510 SvFLAGS(sv) &= ~SVTYPEMASK;
4511 SvFLAGS(sv) |= SVt_PVMG;
4515 Perl_sv_unref(pTHX_ SV *sv)
4519 if (SvWEAKREF(sv)) {
4527 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4530 sv_2mortal(rv); /* Schedule for freeing later */
4534 Perl_sv_taint(pTHX_ SV *sv)
4536 sv_magic((sv), Nullsv, 't', Nullch, 0);
4540 Perl_sv_untaint(pTHX_ SV *sv)
4542 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4543 MAGIC *mg = mg_find(sv, 't');
4550 Perl_sv_tainted(pTHX_ SV *sv)
4552 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4553 MAGIC *mg = mg_find(sv, 't');
4554 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4561 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4563 char buf[TYPE_CHARS(UV)];
4565 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4567 sv_setpvn(sv, ptr, ebuf - ptr);
4572 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4574 char buf[TYPE_CHARS(UV)];
4576 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4578 sv_setpvn(sv, ptr, ebuf - ptr);
4582 #if defined(PERL_IMPLICIT_CONTEXT)
4584 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4588 va_start(args, pat);
4589 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4595 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4599 va_start(args, pat);
4600 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4607 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4610 va_start(args, pat);
4611 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4617 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4620 va_start(args, pat);
4621 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4626 #if defined(PERL_IMPLICIT_CONTEXT)
4628 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4632 va_start(args, pat);
4633 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4638 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4642 va_start(args, pat);
4643 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4650 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4653 va_start(args, pat);
4654 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4659 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4662 va_start(args, pat);
4663 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4669 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4671 sv_setpvn(sv, "", 0);
4672 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4676 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4684 static char nullstr[] = "(null)";
4686 /* no matter what, this is a string now */
4687 (void)SvPV_force(sv, origlen);
4689 /* special-case "", "%s", and "%_" */
4692 if (patlen == 2 && pat[0] == '%') {
4696 char *s = va_arg(*args, char*);
4697 sv_catpv(sv, s ? s : nullstr);
4699 else if (svix < svmax)
4700 sv_catsv(sv, *svargs);
4704 sv_catsv(sv, va_arg(*args, SV*));
4707 /* See comment on '_' below */
4712 patend = (char*)pat + patlen;
4713 for (p = (char*)pat; p < patend; p = q) {
4721 bool has_precis = FALSE;
4726 STRLEN esignlen = 0;
4728 char *eptr = Nullch;
4730 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4741 for (q = p; q < patend && *q != '%'; ++q) ;
4743 sv_catpvn(sv, p, q - p);
4781 case '1': case '2': case '3':
4782 case '4': case '5': case '6':
4783 case '7': case '8': case '9':
4786 width = width * 10 + (*q++ - '0');
4791 i = va_arg(*args, int);
4793 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4795 width = (i < 0) ? -i : i;
4806 i = va_arg(*args, int);
4808 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4809 precis = (i < 0) ? 0 : i;
4815 precis = precis * 10 + (*q++ - '0');
4824 #if 0 /* when quads have better support within Perl */
4825 if (*(q + 1) == 'l') {
4852 uv = va_arg(*args, int);
4854 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4856 eptr = (char*)utf8buf;
4857 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4861 c = va_arg(*args, int);
4863 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4870 eptr = va_arg(*args, char*);
4872 elen = strlen(eptr);
4875 elen = sizeof nullstr - 1;
4878 else if (svix < svmax) {
4879 eptr = SvPVx(svargs[svix++], elen);
4881 if (has_precis && precis < elen) {
4883 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4886 if (width) { /* fudge width (can't fudge elen) */
4887 width += elen - sv_len_utf8(svargs[svix - 1]);
4895 * The "%_" hack might have to be changed someday,
4896 * if ISO or ANSI decide to use '_' for something.
4897 * So we keep it hidden from users' code.
4901 eptr = SvPVx(va_arg(*args, SV*), elen);
4904 if (has_precis && elen > precis)
4912 uv = (UV)va_arg(*args, void*);
4914 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4925 case 'h': iv = (short)va_arg(*args, int); break;
4926 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;
4932 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4934 case 'h': iv = (short)iv; break;
4935 default: iv = (int)iv; break;
4936 case 'l': iv = (long)iv; break;
4943 esignbuf[esignlen++] = plus;
4947 esignbuf[esignlen++] = '-';
4977 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4978 default: uv = va_arg(*args, unsigned); break;
4979 case 'l': uv = va_arg(*args, unsigned long); break;
4980 case 'V': uv = va_arg(*args, UV); break;
4984 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4986 case 'h': uv = (unsigned short)uv; break;
4987 default: uv = (unsigned)uv; break;
4988 case 'l': uv = (unsigned long)uv; break;
4994 eptr = ebuf + sizeof ebuf;
5000 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5006 esignbuf[esignlen++] = '0';
5007 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5013 *--eptr = '0' + dig;
5015 if (alt && *eptr != '0')
5021 *--eptr = '0' + dig;
5023 if (alt && *eptr != '0')
5026 default: /* it had better be ten or less */
5029 *--eptr = '0' + dig;
5030 } while (uv /= base);
5033 elen = (ebuf + sizeof ebuf) - eptr;
5036 zeros = precis - elen;
5037 else if (precis == 0 && elen == 1 && *eptr == '0')
5042 /* FLOATING POINT */
5045 c = 'f'; /* maybe %F isn't supported here */
5051 /* This is evil, but floating point is even more evil */
5054 nv = va_arg(*args, double);
5056 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5059 if (c != 'e' && c != 'E') {
5061 (void)frexp(nv, &i);
5062 if (i == PERL_INT_MIN)
5063 Perl_die(aTHX_ "panic: frexp");
5065 need = BIT_DIGITS(i);
5067 need += has_precis ? precis : 6; /* known default */
5071 need += 20; /* fudge factor */
5072 if (PL_efloatsize < need) {
5073 Safefree(PL_efloatbuf);
5074 PL_efloatsize = need + 20; /* more fudge */
5075 New(906, PL_efloatbuf, PL_efloatsize, char);
5078 eptr = ebuf + sizeof ebuf;
5083 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5088 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5101 RESTORE_NUMERIC_STANDARD();
5102 (void)sprintf(PL_efloatbuf, eptr, nv);
5103 RESTORE_NUMERIC_LOCAL();
5106 eptr = PL_efloatbuf;
5107 elen = strlen(PL_efloatbuf);
5111 * User-defined locales may include arbitrary characters.
5112 * And, unfortunately, some system may alloc the "C" locale
5113 * to be overridden by a malicious user.
5116 *used_locale = TRUE;
5117 #endif /* LC_NUMERIC */
5124 i = SvCUR(sv) - origlen;
5127 case 'h': *(va_arg(*args, short*)) = i; break;
5128 default: *(va_arg(*args, int*)) = i; break;
5129 case 'l': *(va_arg(*args, long*)) = i; break;
5130 case 'V': *(va_arg(*args, IV*)) = i; break;
5133 else if (svix < svmax)
5134 sv_setuv(svargs[svix++], (UV)i);
5135 continue; /* not "break" */
5141 if (!args && ckWARN(WARN_PRINTF) &&
5142 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5143 SV *msg = sv_newmortal();
5144 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5145 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5147 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5150 sv_catpv(msg, "end of string");
5151 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5154 /* output mangled stuff ... */
5160 /* ... right here, because formatting flags should not apply */
5161 SvGROW(sv, SvCUR(sv) + elen + 1);
5163 memcpy(p, eptr, elen);
5166 SvCUR(sv) = p - SvPVX(sv);
5167 continue; /* not "break" */
5170 have = esignlen + zeros + elen;
5171 need = (have > width ? have : width);
5174 SvGROW(sv, SvCUR(sv) + need + 1);
5176 if (esignlen && fill == '0') {
5177 for (i = 0; i < esignlen; i++)
5181 memset(p, fill, gap);
5184 if (esignlen && fill != '0') {
5185 for (i = 0; i < esignlen; i++)
5189 for (i = zeros; i; i--)
5193 memcpy(p, eptr, elen);
5197 memset(p, ' ', gap);
5201 SvCUR(sv) = p - SvPVX(sv);