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(pTHX_ 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 SET_NUMERIC_STANDARD();
1214 d = atof(SvPVX(sv));
1216 if (SvTYPE(sv) < SVt_PVNV)
1217 sv_upgrade(sv, SVt_PVNV);
1221 DEBUG_c(PerlIO_printf(Perl_debug_log,
1222 "0x%lx 2nv(%g)\n",(unsigned long)sv,
1224 if (SvNVX(sv) < (double)IV_MAX + 0.5)
1225 SvIVX(sv) = I_V(SvNVX(sv));
1227 SvUVX(sv) = U_V(SvNVX(sv));
1233 /* The NV may be reconstructed from IV - safe to cache IV,
1234 which may be calculated by atol(). */
1235 if (SvTYPE(sv) == SVt_PV)
1236 sv_upgrade(sv, SVt_PVIV);
1238 SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
1240 else { /* Not a number. Cache 0. */
1243 if (SvTYPE(sv) < SVt_PVIV)
1244 sv_upgrade(sv, SVt_PVIV);
1247 if (ckWARN(WARN_NUMERIC))
1253 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1254 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1255 if (SvTYPE(sv) < SVt_IV)
1256 /* Typically the caller expects that sv_any is not NULL now. */
1257 sv_upgrade(sv, SVt_IV);
1260 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1261 (unsigned long)sv,(long)SvIVX(sv)));
1262 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1266 Perl_sv_2uv(pTHX_ register SV *sv)
1270 if (SvGMAGICAL(sv)) {
1275 return U_V(SvNVX(sv));
1276 if (SvPOKp(sv) && SvLEN(sv))
1279 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1281 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1282 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1287 if (SvTHINKFIRST(sv)) {
1290 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1291 return SvUV(tmpstr);
1292 return (UV)SvRV(sv);
1294 if (SvREADONLY(sv)) {
1296 return U_V(SvNVX(sv));
1298 if (SvPOKp(sv) && SvLEN(sv))
1302 if (ckWARN(WARN_UNINITIALIZED))
1303 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1313 return (UV)SvIVX(sv);
1317 /* We can cache the IV/UV value even if it not good enough
1318 * to reconstruct NV, since the conversion to PV will prefer
1319 * NV over IV/UV. XXXX 64-bit?
1321 if (SvTYPE(sv) == SVt_NV)
1322 sv_upgrade(sv, SVt_PVNV);
1324 if (SvNVX(sv) >= -0.5) {
1326 SvUVX(sv) = U_V(SvNVX(sv));
1329 SvIVX(sv) = I_V(SvNVX(sv));
1331 DEBUG_c(PerlIO_printf(Perl_debug_log,
1332 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1333 (unsigned long)sv,(long)SvIVX(sv),
1334 (long)(UV)SvIVX(sv)));
1335 return (UV)SvIVX(sv);
1338 else if (SvPOKp(sv) && SvLEN(sv)) {
1339 I32 numtype = looks_like_number(sv);
1341 /* We want to avoid a possible problem when we cache a UV which
1342 may be later translated to an NV, and the resulting NV is not
1343 the translation of the initial data.
1345 This means that if we cache such a UV, we need to cache the
1346 NV as well. Moreover, we trade speed for space, and do not
1347 cache the NV if not needed.
1349 if (numtype & IS_NUMBER_NOT_IV) {
1350 /* May be not an integer. Need to cache NV if we cache IV
1351 * - otherwise future conversion to NV will be wrong. */
1354 SET_NUMERIC_STANDARD();
1355 d = atof(SvPVX(sv)); /* XXXX 64-bit? */
1357 if (SvTYPE(sv) < SVt_PVNV)
1358 sv_upgrade(sv, SVt_PVNV);
1362 DEBUG_c(PerlIO_printf(Perl_debug_log,
1363 "0x%lx 2nv(%g)\n",(unsigned long)sv,
1365 if (SvNVX(sv) < -0.5) {
1366 SvIVX(sv) = I_V(SvNVX(sv));
1369 SvUVX(sv) = U_V(SvNVX(sv));
1373 else if (numtype & IS_NUMBER_NEG) {
1374 /* The NV may be reconstructed from IV - safe to cache IV,
1375 which may be calculated by atol(). */
1376 if (SvTYPE(sv) == SVt_PV)
1377 sv_upgrade(sv, SVt_PVIV);
1379 SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1381 else if (numtype) { /* Non-negative */
1382 /* The NV may be reconstructed from UV - safe to cache UV,
1383 which may be calculated by strtoul()/atol. */
1384 if (SvTYPE(sv) == SVt_PV)
1385 sv_upgrade(sv, SVt_PVIV);
1387 (void)SvIsUV_on(sv);
1389 SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
1390 #else /* no atou(), but we know the number fits into IV... */
1391 /* The only problem may be if it is negative... */
1392 SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1395 else { /* Not a number. Cache 0. */
1398 if (SvTYPE(sv) < SVt_PVIV)
1399 sv_upgrade(sv, SVt_PVIV);
1400 SvUVX(sv) = 0; /* We assume that 0s have the
1401 same bitmap in IV and UV. */
1403 (void)SvIsUV_on(sv);
1404 if (ckWARN(WARN_NUMERIC))
1409 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1411 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1412 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1414 if (SvTYPE(sv) < SVt_IV)
1415 /* Typically the caller expects that sv_any is not NULL now. */
1416 sv_upgrade(sv, SVt_IV);
1420 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1421 (unsigned long)sv,SvUVX(sv)));
1422 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1426 Perl_sv_2nv(pTHX_ register SV *sv)
1430 if (SvGMAGICAL(sv)) {
1434 if (SvPOKp(sv) && SvLEN(sv)) {
1436 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1438 SET_NUMERIC_STANDARD();
1439 return atof(SvPVX(sv));
1443 return (double)SvUVX(sv);
1445 return (double)SvIVX(sv);
1448 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1450 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1451 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1456 if (SvTHINKFIRST(sv)) {
1459 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1460 return SvNV(tmpstr);
1461 return (double)(unsigned long)SvRV(sv);
1463 if (SvREADONLY(sv)) {
1465 if (SvPOKp(sv) && SvLEN(sv)) {
1466 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1468 SET_NUMERIC_STANDARD();
1469 return atof(SvPVX(sv));
1473 return (double)SvUVX(sv);
1475 return (double)SvIVX(sv);
1477 if (ckWARN(WARN_UNINITIALIZED))
1478 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1482 if (SvTYPE(sv) < SVt_NV) {
1483 if (SvTYPE(sv) == SVt_IV)
1484 sv_upgrade(sv, SVt_PVNV);
1486 sv_upgrade(sv, SVt_NV);
1487 DEBUG_c(SET_NUMERIC_STANDARD());
1488 DEBUG_c(PerlIO_printf(Perl_debug_log,
1489 "0x%lx num(%g)\n",(unsigned long)sv,SvNVX(sv)));
1491 else if (SvTYPE(sv) < SVt_PVNV)
1492 sv_upgrade(sv, SVt_PVNV);
1494 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1496 SvNVX(sv) = SvIsUV(sv) ? (double)SvUVX(sv) : (double)SvIVX(sv);
1498 else if (SvPOKp(sv) && SvLEN(sv)) {
1500 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1502 SET_NUMERIC_STANDARD();
1503 SvNVX(sv) = atof(SvPVX(sv));
1507 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1508 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1509 if (SvTYPE(sv) < SVt_NV)
1510 /* Typically the caller expects that sv_any is not NULL now. */
1511 sv_upgrade(sv, SVt_NV);
1515 DEBUG_c(SET_NUMERIC_STANDARD());
1516 DEBUG_c(PerlIO_printf(Perl_debug_log,
1517 "0x%lx 2nv(%g)\n",(unsigned long)sv,SvNVX(sv)));
1522 S_asIV(pTHX_ SV *sv)
1524 I32 numtype = looks_like_number(sv);
1527 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1528 return atol(SvPVX(sv)); /* XXXX 64-bit? */
1531 if (ckWARN(WARN_NUMERIC))
1534 SET_NUMERIC_STANDARD();
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 SET_NUMERIC_STANDARD();
1554 return U_V(atof(SvPVX(sv)));
1558 * Returns a combination of (advisory only - can get false negatives)
1559 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1561 * 0 if does not look like number.
1563 * In fact possible values are 0 and
1564 * IS_NUMBER_TO_INT_BY_ATOL 123
1565 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1566 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1567 * with a possible addition of IS_NUMBER_NEG.
1571 Perl_looks_like_number(pTHX_ SV *sv)
1573 /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
1574 * using atof() may lose precision. */
1576 register char *send;
1577 register char *sbegin;
1578 register char *nbegin;
1586 else if (SvPOKp(sv))
1587 sbegin = SvPV(sv, len);
1590 send = sbegin + len;
1597 numtype = IS_NUMBER_NEG;
1604 * we return 1 if the number can be converted to _integer_ with atol()
1605 * and 2 if you need (int)atof().
1608 /* next must be digit or '.' */
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;
1621 numtype |= IS_NUMBER_NOT_IV;
1622 while (isDIGIT(*s)) /* optional digits after "." */
1626 else if (*s == '.') {
1628 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1629 /* no digits before '.' means we need digits after it */
1633 } while (isDIGIT(*s));
1641 /* we can have an optional exponent part */
1642 if (*s == 'e' || *s == 'E') {
1643 numtype &= ~IS_NUMBER_NEG;
1644 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1646 if (*s == '+' || *s == '-')
1651 } while (isDIGIT(*s));
1660 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1661 return IS_NUMBER_TO_INT_BY_ATOL;
1666 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1669 return sv_2pv(sv, &n_a);
1672 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1674 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1677 char *ptr = buf + TYPE_CHARS(UV);
1692 *--ptr = '0' + (uv % 10);
1701 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1706 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1707 char *tmpbuf = tbuf;
1713 if (SvGMAGICAL(sv)) {
1719 if (SvIOKp(sv)) { /* XXXX 64-bit? */
1721 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1723 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1728 SET_NUMERIC_STANDARD();
1729 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1734 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1736 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1737 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1743 if (SvTHINKFIRST(sv)) {
1746 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1747 return SvPV(tmpstr,*lp);
1754 switch (SvTYPE(sv)) {
1756 if ( ((SvFLAGS(sv) &
1757 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1758 == (SVs_OBJECT|SVs_RMG))
1759 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1760 && (mg = mg_find(sv, 'r'))) {
1762 regexp *re = (regexp *)mg->mg_obj;
1765 char *fptr = "msix";
1770 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1772 while(ch = *fptr++) {
1774 reflags[left++] = ch;
1777 reflags[right--] = ch;
1782 reflags[left] = '-';
1786 mg->mg_len = re->prelen + 4 + left;
1787 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1788 Copy("(?", mg->mg_ptr, 2, char);
1789 Copy(reflags, mg->mg_ptr+2, left, char);
1790 Copy(":", mg->mg_ptr+left+2, 1, char);
1791 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1792 mg->mg_ptr[mg->mg_len - 1] = ')';
1793 mg->mg_ptr[mg->mg_len] = 0;
1795 PL_reginterp_cnt += re->program[0].next_off;
1807 case SVt_PVBM: s = "SCALAR"; break;
1808 case SVt_PVLV: s = "LVALUE"; break;
1809 case SVt_PVAV: s = "ARRAY"; break;
1810 case SVt_PVHV: s = "HASH"; break;
1811 case SVt_PVCV: s = "CODE"; break;
1812 case SVt_PVGV: s = "GLOB"; break;
1813 case SVt_PVFM: s = "FORMAT"; break;
1814 case SVt_PVIO: s = "IO"; break;
1815 default: s = "UNKNOWN"; break;
1819 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1823 Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
1829 if (SvREADONLY(sv)) {
1830 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1831 /* XXXX 64-bit? IV may have better precision... */
1832 SET_NUMERIC_STANDARD();
1833 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1841 tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
1843 tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
1850 if (ckWARN(WARN_UNINITIALIZED))
1851 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1857 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1858 /* XXXX 64-bit? IV may have better precision... */
1859 if (SvTYPE(sv) < SVt_PVNV)
1860 sv_upgrade(sv, SVt_PVNV);
1863 olderrno = errno; /* some Xenix systems wipe out errno here */
1865 if (SvNVX(sv) == 0.0)
1866 (void)strcpy(s,"0");
1870 SET_NUMERIC_STANDARD();
1871 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1874 #ifdef FIXNEGATIVEZERO
1875 if (*s == '-' && s[1] == '0' && !s[2])
1884 else if (SvIOKp(sv)) {
1885 U32 isIOK = SvIOK(sv);
1886 char buf[TYPE_CHARS(UV)];
1889 if (SvTYPE(sv) < SVt_PVIV)
1890 sv_upgrade(sv, SVt_PVIV);
1892 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1893 sv_setpvn(sv, ptr, ebuf - ptr);
1897 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1898 sv_setpvn(sv, ptr, ebuf - ptr);
1908 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1909 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1911 if (SvTYPE(sv) < SVt_PV)
1912 /* Typically the caller expects that sv_any is not NULL now. */
1913 sv_upgrade(sv, SVt_PV);
1916 *lp = s - SvPVX(sv);
1919 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1923 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1924 /* Sneaky stuff here */
1928 tsv = newSVpv(tmpbuf, 0);
1944 len = strlen(tmpbuf);
1946 #ifdef FIXNEGATIVEZERO
1947 if (len == 2 && t[0] == '-' && t[1] == '0') {
1952 (void)SvUPGRADE(sv, SVt_PV);
1954 s = SvGROW(sv, len + 1);
1962 /* This function is only called on magical items */
1964 Perl_sv_2bool(pTHX_ register SV *sv)
1974 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
1975 return SvTRUE(tmpsv);
1976 return SvRV(sv) != 0;
1979 register XPV* Xpvtmp;
1980 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
1981 (*Xpvtmp->xpv_pv > '0' ||
1982 Xpvtmp->xpv_cur > 1 ||
1983 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
1990 return SvIVX(sv) != 0;
1993 return SvNVX(sv) != 0.0;
2000 /* Note: sv_setsv() should not be called with a source string that needs
2001 * to be reused, since it may destroy the source string if it is marked
2006 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2009 register U32 sflags;
2015 SV_CHECK_THINKFIRST(dstr);
2017 sstr = &PL_sv_undef;
2018 stype = SvTYPE(sstr);
2019 dtype = SvTYPE(dstr);
2023 /* There's a lot of redundancy below but we're going for speed here */
2028 if (dtype != SVt_PVGV) {
2029 (void)SvOK_off(dstr);
2037 sv_upgrade(dstr, SVt_IV);
2040 sv_upgrade(dstr, SVt_PVNV);
2044 sv_upgrade(dstr, SVt_PVIV);
2047 (void)SvIOK_only(dstr);
2048 SvIVX(dstr) = SvIVX(sstr);
2061 sv_upgrade(dstr, SVt_NV);
2066 sv_upgrade(dstr, SVt_PVNV);
2069 SvNVX(dstr) = SvNVX(sstr);
2070 (void)SvNOK_only(dstr);
2078 sv_upgrade(dstr, SVt_RV);
2079 else if (dtype == SVt_PVGV &&
2080 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2083 if (PL_curcop->cop_stash != GvSTASH(dstr))
2084 GvIMPORTED_on(dstr);
2094 sv_upgrade(dstr, SVt_PV);
2097 if (dtype < SVt_PVIV)
2098 sv_upgrade(dstr, SVt_PVIV);
2101 if (dtype < SVt_PVNV)
2102 sv_upgrade(dstr, SVt_PVNV);
2109 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2110 PL_op_name[PL_op->op_type]);
2112 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2116 if (dtype <= SVt_PVGV) {
2118 if (dtype != SVt_PVGV) {
2119 char *name = GvNAME(sstr);
2120 STRLEN len = GvNAMELEN(sstr);
2121 sv_upgrade(dstr, SVt_PVGV);
2122 sv_magic(dstr, dstr, '*', name, len);
2123 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2124 GvNAME(dstr) = savepvn(name, len);
2125 GvNAMELEN(dstr) = len;
2126 SvFAKE_on(dstr); /* can coerce to non-glob */
2128 /* ahem, death to those who redefine active sort subs */
2129 else if (PL_curstackinfo->si_type == PERLSI_SORT
2130 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2131 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2133 (void)SvOK_off(dstr);
2134 GvINTRO_off(dstr); /* one-shot flag */
2136 GvGP(dstr) = gp_ref(GvGP(sstr));
2138 if (PL_curcop->cop_stash != GvSTASH(dstr))
2139 GvIMPORTED_on(dstr);
2146 if (SvGMAGICAL(sstr)) {
2148 if (SvTYPE(sstr) != stype) {
2149 stype = SvTYPE(sstr);
2150 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2154 if (stype == SVt_PVLV)
2155 (void)SvUPGRADE(dstr, SVt_PVNV);
2157 (void)SvUPGRADE(dstr, stype);
2160 sflags = SvFLAGS(sstr);
2162 if (sflags & SVf_ROK) {
2163 if (dtype >= SVt_PV) {
2164 if (dtype == SVt_PVGV) {
2165 SV *sref = SvREFCNT_inc(SvRV(sstr));
2167 int intro = GvINTRO(dstr);
2171 GvGP(dstr)->gp_refcnt--;
2172 GvINTRO_off(dstr); /* one-shot flag */
2173 Newz(602,gp, 1, GP);
2174 GvGP(dstr) = gp_ref(gp);
2175 GvSV(dstr) = NEWSV(72,0);
2176 GvLINE(dstr) = PL_curcop->cop_line;
2177 GvEGV(dstr) = (GV*)dstr;
2180 switch (SvTYPE(sref)) {
2183 SAVESPTR(GvAV(dstr));
2185 dref = (SV*)GvAV(dstr);
2186 GvAV(dstr) = (AV*)sref;
2187 if (PL_curcop->cop_stash != GvSTASH(dstr))
2188 GvIMPORTED_AV_on(dstr);
2192 SAVESPTR(GvHV(dstr));
2194 dref = (SV*)GvHV(dstr);
2195 GvHV(dstr) = (HV*)sref;
2196 if (PL_curcop->cop_stash != GvSTASH(dstr))
2197 GvIMPORTED_HV_on(dstr);
2201 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2202 SvREFCNT_dec(GvCV(dstr));
2203 GvCV(dstr) = Nullcv;
2204 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2205 PL_sub_generation++;
2207 SAVESPTR(GvCV(dstr));
2210 dref = (SV*)GvCV(dstr);
2211 if (GvCV(dstr) != (CV*)sref) {
2212 CV* cv = GvCV(dstr);
2214 if (!GvCVGEN((GV*)dstr) &&
2215 (CvROOT(cv) || CvXSUB(cv)))
2217 SV *const_sv = cv_const_sv(cv);
2218 bool const_changed = TRUE;
2220 const_changed = sv_cmp(const_sv,
2221 op_const_sv(CvSTART((CV*)sref),
2223 /* ahem, death to those who redefine
2224 * active sort subs */
2225 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2226 PL_sortcop == CvSTART(cv))
2228 "Can't redefine active sort subroutine %s",
2229 GvENAME((GV*)dstr));
2230 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2231 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2232 && HvNAME(GvSTASH(CvGV(cv)))
2233 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2235 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2236 "Constant subroutine %s redefined"
2237 : "Subroutine %s redefined",
2238 GvENAME((GV*)dstr));
2241 cv_ckproto(cv, (GV*)dstr,
2242 SvPOK(sref) ? SvPVX(sref) : Nullch);
2244 GvCV(dstr) = (CV*)sref;
2245 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2246 GvASSUMECV_on(dstr);
2247 PL_sub_generation++;
2249 if (PL_curcop->cop_stash != GvSTASH(dstr))
2250 GvIMPORTED_CV_on(dstr);
2254 SAVESPTR(GvIOp(dstr));
2256 dref = (SV*)GvIOp(dstr);
2257 GvIOp(dstr) = (IO*)sref;
2261 SAVESPTR(GvSV(dstr));
2263 dref = (SV*)GvSV(dstr);
2265 if (PL_curcop->cop_stash != GvSTASH(dstr))
2266 GvIMPORTED_SV_on(dstr);
2277 (void)SvOOK_off(dstr); /* backoff */
2279 Safefree(SvPVX(dstr));
2280 SvLEN(dstr)=SvCUR(dstr)=0;
2283 (void)SvOK_off(dstr);
2284 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2286 if (sflags & SVp_NOK) {
2288 SvNVX(dstr) = SvNVX(sstr);
2290 if (sflags & SVp_IOK) {
2291 (void)SvIOK_on(dstr);
2292 SvIVX(dstr) = SvIVX(sstr);
2296 if (SvAMAGIC(sstr)) {
2300 else if (sflags & SVp_POK) {
2303 * Check to see if we can just swipe the string. If so, it's a
2304 * possible small lose on short strings, but a big win on long ones.
2305 * It might even be a win on short strings if SvPVX(dstr)
2306 * has to be allocated and SvPVX(sstr) has to be freed.
2309 if (SvTEMP(sstr) && /* slated for free anyway? */
2310 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2311 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2313 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2315 SvFLAGS(dstr) &= ~SVf_OOK;
2316 Safefree(SvPVX(dstr) - SvIVX(dstr));
2318 else if (SvLEN(dstr))
2319 Safefree(SvPVX(dstr));
2321 (void)SvPOK_only(dstr);
2322 SvPV_set(dstr, SvPVX(sstr));
2323 SvLEN_set(dstr, SvLEN(sstr));
2324 SvCUR_set(dstr, SvCUR(sstr));
2326 (void)SvOK_off(sstr);
2327 SvPV_set(sstr, Nullch);
2332 else { /* have to copy actual string */
2333 STRLEN len = SvCUR(sstr);
2335 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2336 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2337 SvCUR_set(dstr, len);
2338 *SvEND(dstr) = '\0';
2339 (void)SvPOK_only(dstr);
2342 if (sflags & SVp_NOK) {
2344 SvNVX(dstr) = SvNVX(sstr);
2346 if (sflags & SVp_IOK) {
2347 (void)SvIOK_on(dstr);
2348 SvIVX(dstr) = SvIVX(sstr);
2353 else if (sflags & SVp_NOK) {
2354 SvNVX(dstr) = SvNVX(sstr);
2355 (void)SvNOK_only(dstr);
2357 (void)SvIOK_on(dstr);
2358 SvIVX(dstr) = SvIVX(sstr);
2359 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2364 else if (sflags & SVp_IOK) {
2365 (void)SvIOK_only(dstr);
2366 SvIVX(dstr) = SvIVX(sstr);
2371 if (dtype == SVt_PVGV) {
2372 if (ckWARN(WARN_UNSAFE))
2373 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2376 (void)SvOK_off(dstr);
2382 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2384 sv_setsv(dstr,sstr);
2389 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2391 register char *dptr;
2392 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2393 elicit a warning, but it won't hurt. */
2394 SV_CHECK_THINKFIRST(sv);
2399 (void)SvUPGRADE(sv, SVt_PV);
2401 SvGROW(sv, len + 1);
2403 Move(ptr,dptr,len,char);
2406 (void)SvPOK_only(sv); /* validate pointer */
2411 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2413 sv_setpvn(sv,ptr,len);
2418 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2420 register STRLEN len;
2422 SV_CHECK_THINKFIRST(sv);
2428 (void)SvUPGRADE(sv, SVt_PV);
2430 SvGROW(sv, len + 1);
2431 Move(ptr,SvPVX(sv),len+1,char);
2433 (void)SvPOK_only(sv); /* validate pointer */
2438 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2445 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2447 SV_CHECK_THINKFIRST(sv);
2448 (void)SvUPGRADE(sv, SVt_PV);
2453 (void)SvOOK_off(sv);
2454 if (SvPVX(sv) && SvLEN(sv))
2455 Safefree(SvPVX(sv));
2456 Renew(ptr, len+1, char);
2459 SvLEN_set(sv, len+1);
2461 (void)SvPOK_only(sv); /* validate pointer */
2466 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2468 sv_usepvn(sv,ptr,len);
2473 Perl_sv_force_normal(pTHX_ register SV *sv)
2475 if (SvREADONLY(sv)) {
2477 if (PL_curcop != &PL_compiling)
2478 Perl_croak(aTHX_ PL_no_modify);
2482 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2487 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2491 register STRLEN delta;
2493 if (!ptr || !SvPOKp(sv))
2495 SV_CHECK_THINKFIRST(sv);
2496 if (SvTYPE(sv) < SVt_PVIV)
2497 sv_upgrade(sv,SVt_PVIV);
2500 if (!SvLEN(sv)) { /* make copy of shared string */
2501 char *pvx = SvPVX(sv);
2502 STRLEN len = SvCUR(sv);
2503 SvGROW(sv, len + 1);
2504 Move(pvx,SvPVX(sv),len,char);
2508 SvFLAGS(sv) |= SVf_OOK;
2510 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2511 delta = ptr - SvPVX(sv);
2519 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2524 junk = SvPV_force(sv, tlen);
2525 SvGROW(sv, tlen + len + 1);
2528 Move(ptr,SvPVX(sv)+tlen,len,char);
2531 (void)SvPOK_only(sv); /* validate pointer */
2536 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2538 sv_catpvn(sv,ptr,len);
2543 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2549 if (s = SvPV(sstr, len))
2550 sv_catpvn(dstr,s,len);
2554 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2556 sv_catsv(dstr,sstr);
2561 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2563 register STRLEN len;
2569 junk = SvPV_force(sv, tlen);
2571 SvGROW(sv, tlen + len + 1);
2574 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2576 (void)SvPOK_only(sv); /* validate pointer */
2581 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2588 Perl_newSV(pTHX_ STRLEN len)
2594 sv_upgrade(sv, SVt_PV);
2595 SvGROW(sv, len + 1);
2600 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2603 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2607 if (SvREADONLY(sv)) {
2609 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2610 Perl_croak(aTHX_ PL_no_modify);
2612 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2613 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2620 (void)SvUPGRADE(sv, SVt_PVMG);
2622 Newz(702,mg, 1, MAGIC);
2623 mg->mg_moremagic = SvMAGIC(sv);
2626 if (!obj || obj == sv || how == '#' || how == 'r')
2630 mg->mg_obj = SvREFCNT_inc(obj);
2631 mg->mg_flags |= MGf_REFCOUNTED;
2634 mg->mg_len = namlen;
2637 mg->mg_ptr = savepvn(name, namlen);
2638 else if (namlen == HEf_SVKEY)
2639 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2643 mg->mg_virtual = &PL_vtbl_sv;
2646 mg->mg_virtual = &PL_vtbl_amagic;
2649 mg->mg_virtual = &PL_vtbl_amagicelem;
2655 mg->mg_virtual = &PL_vtbl_bm;
2658 mg->mg_virtual = &PL_vtbl_regdata;
2661 mg->mg_virtual = &PL_vtbl_regdatum;
2664 mg->mg_virtual = &PL_vtbl_env;
2667 mg->mg_virtual = &PL_vtbl_fm;
2670 mg->mg_virtual = &PL_vtbl_envelem;
2673 mg->mg_virtual = &PL_vtbl_mglob;
2676 mg->mg_virtual = &PL_vtbl_isa;
2679 mg->mg_virtual = &PL_vtbl_isaelem;
2682 mg->mg_virtual = &PL_vtbl_nkeys;
2689 mg->mg_virtual = &PL_vtbl_dbline;
2693 mg->mg_virtual = &PL_vtbl_mutex;
2695 #endif /* USE_THREADS */
2696 #ifdef USE_LOCALE_COLLATE
2698 mg->mg_virtual = &PL_vtbl_collxfrm;
2700 #endif /* USE_LOCALE_COLLATE */
2702 mg->mg_virtual = &PL_vtbl_pack;
2706 mg->mg_virtual = &PL_vtbl_packelem;
2709 mg->mg_virtual = &PL_vtbl_regexp;
2712 mg->mg_virtual = &PL_vtbl_sig;
2715 mg->mg_virtual = &PL_vtbl_sigelem;
2718 mg->mg_virtual = &PL_vtbl_taint;
2722 mg->mg_virtual = &PL_vtbl_uvar;
2725 mg->mg_virtual = &PL_vtbl_vec;
2728 mg->mg_virtual = &PL_vtbl_substr;
2731 mg->mg_virtual = &PL_vtbl_defelem;
2734 mg->mg_virtual = &PL_vtbl_glob;
2737 mg->mg_virtual = &PL_vtbl_arylen;
2740 mg->mg_virtual = &PL_vtbl_pos;
2743 mg->mg_virtual = &PL_vtbl_backref;
2745 case '~': /* Reserved for use by extensions not perl internals. */
2746 /* Useful for attaching extension internal data to perl vars. */
2747 /* Note that multiple extensions may clash if magical scalars */
2748 /* etc holding private data from one are passed to another. */
2752 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
2756 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2760 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2764 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2767 for (mg = *mgp; mg; mg = *mgp) {
2768 if (mg->mg_type == type) {
2769 MGVTBL* vtbl = mg->mg_virtual;
2770 *mgp = mg->mg_moremagic;
2771 if (vtbl && (vtbl->svt_free != NULL))
2772 (VTBL->svt_free)(aTHX_ sv, mg);
2773 if (mg->mg_ptr && mg->mg_type != 'g')
2774 if (mg->mg_len >= 0)
2775 Safefree(mg->mg_ptr);
2776 else if (mg->mg_len == HEf_SVKEY)
2777 SvREFCNT_dec((SV*)mg->mg_ptr);
2778 if (mg->mg_flags & MGf_REFCOUNTED)
2779 SvREFCNT_dec(mg->mg_obj);
2783 mgp = &mg->mg_moremagic;
2787 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2794 Perl_sv_rvweaken(pTHX_ SV *sv)
2797 if (!SvOK(sv)) /* let undefs pass */
2800 Perl_croak(aTHX_ "Can't weaken a nonreference");
2801 else if (SvWEAKREF(sv)) {
2803 if (ckWARN(WARN_MISC))
2804 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
2808 sv_add_backref(tsv, sv);
2815 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
2819 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2820 av = (AV*)mg->mg_obj;
2823 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2824 SvREFCNT_dec(av); /* for sv_magic */
2830 S_sv_del_backref(pTHX_ SV *sv)
2837 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2838 Perl_croak(aTHX_ "panic: del_backref");
2839 av = (AV *)mg->mg_obj;
2844 svp[i] = &PL_sv_undef; /* XXX */
2851 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2855 register char *midend;
2856 register char *bigend;
2862 Perl_croak(aTHX_ "Can't modify non-existent substring");
2863 SvPV_force(bigstr, curlen);
2864 if (offset + len > curlen) {
2865 SvGROW(bigstr, offset+len+1);
2866 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2867 SvCUR_set(bigstr, offset+len);
2870 i = littlelen - len;
2871 if (i > 0) { /* string might grow */
2872 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2873 mid = big + offset + len;
2874 midend = bigend = big + SvCUR(bigstr);
2877 while (midend > mid) /* shove everything down */
2878 *--bigend = *--midend;
2879 Move(little,big+offset,littlelen,char);
2885 Move(little,SvPVX(bigstr)+offset,len,char);
2890 big = SvPVX(bigstr);
2893 bigend = big + SvCUR(bigstr);
2895 if (midend > bigend)
2896 Perl_croak(aTHX_ "panic: sv_insert");
2898 if (mid - big > bigend - midend) { /* faster to shorten from end */
2900 Move(little, mid, littlelen,char);
2903 i = bigend - midend;
2905 Move(midend, mid, i,char);
2909 SvCUR_set(bigstr, mid - big);
2912 else if (i = mid - big) { /* faster from front */
2913 midend -= littlelen;
2915 sv_chop(bigstr,midend-i);
2920 Move(little, mid, littlelen,char);
2922 else if (littlelen) {
2923 midend -= littlelen;
2924 sv_chop(bigstr,midend);
2925 Move(little,midend,littlelen,char);
2928 sv_chop(bigstr,midend);
2933 /* make sv point to what nstr did */
2936 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2938 U32 refcnt = SvREFCNT(sv);
2939 SV_CHECK_THINKFIRST(sv);
2940 if (SvREFCNT(nsv) != 1)
2941 Perl_warn(aTHX_ "Reference miscount in sv_replace()");
2942 if (SvMAGICAL(sv)) {
2946 sv_upgrade(nsv, SVt_PVMG);
2947 SvMAGIC(nsv) = SvMAGIC(sv);
2948 SvFLAGS(nsv) |= SvMAGICAL(sv);
2954 assert(!SvREFCNT(sv));
2955 StructCopy(nsv,sv,SV);
2956 SvREFCNT(sv) = refcnt;
2957 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2962 Perl_sv_clear(pTHX_ register SV *sv)
2966 assert(SvREFCNT(sv) == 0);
2970 if (PL_defstash) { /* Still have a symbol table? */
2975 Zero(&tmpref, 1, SV);
2976 sv_upgrade(&tmpref, SVt_RV);
2978 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
2979 SvREFCNT(&tmpref) = 1;
2982 stash = SvSTASH(sv);
2983 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
2986 PUSHSTACKi(PERLSI_DESTROY);
2987 SvRV(&tmpref) = SvREFCNT_inc(sv);
2992 call_sv((SV*)GvCV(destructor),
2993 G_DISCARD|G_EVAL|G_KEEPERR);
2999 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3001 del_XRV(SvANY(&tmpref));
3004 if (PL_in_clean_objs)
3005 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3007 /* DESTROY gave object new lease on life */
3013 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3014 SvOBJECT_off(sv); /* Curse the object. */
3015 if (SvTYPE(sv) != SVt_PVIO)
3016 --PL_sv_objcount; /* XXX Might want something more general */
3019 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3022 switch (SvTYPE(sv)) {
3025 IoIFP(sv) != PerlIO_stdin() &&
3026 IoIFP(sv) != PerlIO_stdout() &&
3027 IoIFP(sv) != PerlIO_stderr())
3032 PerlDir_close(IoDIRP(sv));
3035 Safefree(IoTOP_NAME(sv));
3036 Safefree(IoFMT_NAME(sv));
3037 Safefree(IoBOTTOM_NAME(sv));
3052 SvREFCNT_dec(LvTARG(sv));
3056 Safefree(GvNAME(sv));
3057 /* cannot decrease stash refcount yet, as we might recursively delete
3058 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3059 of stash until current sv is completely gone.
3060 -- JohnPC, 27 Mar 1998 */
3061 stash = GvSTASH(sv);
3067 (void)SvOOK_off(sv);
3075 SvREFCNT_dec(SvRV(sv));
3077 else if (SvPVX(sv) && SvLEN(sv))
3078 Safefree(SvPVX(sv));
3088 switch (SvTYPE(sv)) {
3104 del_XPVIV(SvANY(sv));
3107 del_XPVNV(SvANY(sv));
3110 del_XPVMG(SvANY(sv));
3113 del_XPVLV(SvANY(sv));
3116 del_XPVAV(SvANY(sv));
3119 del_XPVHV(SvANY(sv));
3122 del_XPVCV(SvANY(sv));
3125 del_XPVGV(SvANY(sv));
3126 /* code duplication for increased performance. */
3127 SvFLAGS(sv) &= SVf_BREAK;
3128 SvFLAGS(sv) |= SVTYPEMASK;
3129 /* decrease refcount of the stash that owns this GV, if any */
3131 SvREFCNT_dec(stash);
3132 return; /* not break, SvFLAGS reset already happened */
3134 del_XPVBM(SvANY(sv));
3137 del_XPVFM(SvANY(sv));
3140 del_XPVIO(SvANY(sv));
3143 SvFLAGS(sv) &= SVf_BREAK;
3144 SvFLAGS(sv) |= SVTYPEMASK;
3148 Perl_sv_newref(pTHX_ SV *sv)
3151 ATOMIC_INC(SvREFCNT(sv));
3156 Perl_sv_free(pTHX_ SV *sv)
3158 int refcount_is_zero;
3162 if (SvREFCNT(sv) == 0) {
3163 if (SvFLAGS(sv) & SVf_BREAK)
3165 if (PL_in_clean_all) /* All is fair */
3167 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3168 /* make sure SvREFCNT(sv)==0 happens very seldom */
3169 SvREFCNT(sv) = (~(U32)0)/2;
3172 Perl_warn(aTHX_ "Attempt to free unreferenced scalar");
3175 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3176 if (!refcount_is_zero)
3180 Perl_warn(aTHX_ "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3184 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3185 /* make sure SvREFCNT(sv)==0 happens very seldom */
3186 SvREFCNT(sv) = (~(U32)0)/2;
3195 Perl_sv_len(pTHX_ register SV *sv)
3204 len = mg_length(sv);
3206 junk = SvPV(sv, len);
3211 Perl_sv_len_utf8(pTHX_ register SV *sv)
3222 len = mg_length(sv);
3225 s = (U8*)SvPV(sv, len);
3236 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3241 I32 uoffset = *offsetp;
3247 start = s = (U8*)SvPV(sv, len);
3249 while (s < send && uoffset--)
3253 *offsetp = s - start;
3257 while (s < send && ulen--)
3267 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3276 s = (U8*)SvPV(sv, len);
3278 Perl_croak(aTHX_ "panic: bad byte offset");
3279 send = s + *offsetp;
3286 Perl_warn(aTHX_ "Malformed UTF-8 character");
3294 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3306 pv1 = SvPV(str1, cur1);
3311 pv2 = SvPV(str2, cur2);
3316 return memEQ(pv1, pv2, cur1);
3320 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3323 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3325 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3329 return cur2 ? -1 : 0;
3334 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3337 return retval < 0 ? -1 : 1;
3342 return cur1 < cur2 ? -1 : 1;
3346 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3348 #ifdef USE_LOCALE_COLLATE
3354 if (PL_collation_standard)
3358 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3360 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3362 if (!pv1 || !len1) {
3373 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3376 return retval < 0 ? -1 : 1;
3379 * When the result of collation is equality, that doesn't mean
3380 * that there are no differences -- some locales exclude some
3381 * characters from consideration. So to avoid false equalities,
3382 * we use the raw string as a tiebreaker.
3388 #endif /* USE_LOCALE_COLLATE */
3390 return sv_cmp(sv1, sv2);
3393 #ifdef USE_LOCALE_COLLATE
3395 * Any scalar variable may carry an 'o' magic that contains the
3396 * scalar data of the variable transformed to such a format that
3397 * a normal memory comparison can be used to compare the data
3398 * according to the locale settings.
3401 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3405 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3406 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3411 Safefree(mg->mg_ptr);
3413 if ((xf = mem_collxfrm(s, len, &xlen))) {
3414 if (SvREADONLY(sv)) {
3417 return xf + sizeof(PL_collation_ix);
3420 sv_magic(sv, 0, 'o', 0, 0);
3421 mg = mg_find(sv, 'o');
3434 if (mg && mg->mg_ptr) {
3436 return mg->mg_ptr + sizeof(PL_collation_ix);
3444 #endif /* USE_LOCALE_COLLATE */
3447 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3452 register STDCHAR rslast;
3453 register STDCHAR *bp;
3457 SV_CHECK_THINKFIRST(sv);
3458 (void)SvUPGRADE(sv, SVt_PV);
3462 if (RsSNARF(PL_rs)) {
3466 else if (RsRECORD(PL_rs)) {
3467 I32 recsize, bytesread;
3470 /* Grab the size of the record we're getting */
3471 recsize = SvIV(SvRV(PL_rs));
3472 (void)SvPOK_only(sv); /* Validate pointer */
3473 buffer = SvGROW(sv, recsize + 1);
3476 /* VMS wants read instead of fread, because fread doesn't respect */
3477 /* RMS record boundaries. This is not necessarily a good thing to be */
3478 /* doing, but we've got no other real choice */
3479 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3481 bytesread = PerlIO_read(fp, buffer, recsize);
3483 SvCUR_set(sv, bytesread);
3484 buffer[bytesread] = '\0';
3485 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3487 else if (RsPARA(PL_rs)) {
3492 rsptr = SvPV(PL_rs, rslen);
3493 rslast = rslen ? rsptr[rslen - 1] : '\0';
3495 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3496 do { /* to make sure file boundaries work right */
3499 i = PerlIO_getc(fp);
3503 PerlIO_ungetc(fp,i);
3509 /* See if we know enough about I/O mechanism to cheat it ! */
3511 /* This used to be #ifdef test - it is made run-time test for ease
3512 of abstracting out stdio interface. One call should be cheap
3513 enough here - and may even be a macro allowing compile
3517 if (PerlIO_fast_gets(fp)) {
3520 * We're going to steal some values from the stdio struct
3521 * and put EVERYTHING in the innermost loop into registers.
3523 register STDCHAR *ptr;
3527 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3528 /* An ungetc()d char is handled separately from the regular
3529 * buffer, so we getc() it back out and stuff it in the buffer.
3531 i = PerlIO_getc(fp);
3532 if (i == EOF) return 0;
3533 *(--((*fp)->_ptr)) = (unsigned char) i;
3537 /* Here is some breathtakingly efficient cheating */
3539 cnt = PerlIO_get_cnt(fp); /* get count into register */
3540 (void)SvPOK_only(sv); /* validate pointer */
3541 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3542 if (cnt > 80 && SvLEN(sv) > append) {
3543 shortbuffered = cnt - SvLEN(sv) + append + 1;
3544 cnt -= shortbuffered;
3548 /* remember that cnt can be negative */
3549 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3554 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3555 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3556 DEBUG_P(PerlIO_printf(Perl_debug_log,
3557 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3558 DEBUG_P(PerlIO_printf(Perl_debug_log,
3559 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3560 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3561 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3566 while (cnt > 0) { /* this | eat */
3568 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3569 goto thats_all_folks; /* screams | sed :-) */
3573 Copy(ptr, bp, cnt, char); /* this | eat */
3574 bp += cnt; /* screams | dust */
3575 ptr += cnt; /* louder | sed :-) */
3580 if (shortbuffered) { /* oh well, must extend */
3581 cnt = shortbuffered;
3583 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3585 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3586 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3590 DEBUG_P(PerlIO_printf(Perl_debug_log,
3591 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3592 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3593 DEBUG_P(PerlIO_printf(Perl_debug_log,
3594 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3595 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3596 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3597 /* This used to call 'filbuf' in stdio form, but as that behaves like
3598 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3599 another abstraction. */
3600 i = PerlIO_getc(fp); /* get more characters */
3601 DEBUG_P(PerlIO_printf(Perl_debug_log,
3602 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3603 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3604 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3605 cnt = PerlIO_get_cnt(fp);
3606 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3607 DEBUG_P(PerlIO_printf(Perl_debug_log,
3608 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3610 if (i == EOF) /* all done for ever? */
3611 goto thats_really_all_folks;
3613 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3615 SvGROW(sv, bpx + cnt + 2);
3616 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3618 *bp++ = i; /* store character from PerlIO_getc */
3620 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3621 goto thats_all_folks;
3625 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3626 memNE((char*)bp - rslen, rsptr, rslen))
3627 goto screamer; /* go back to the fray */
3628 thats_really_all_folks:
3630 cnt += shortbuffered;
3631 DEBUG_P(PerlIO_printf(Perl_debug_log,
3632 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3633 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3634 DEBUG_P(PerlIO_printf(Perl_debug_log,
3635 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3636 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3637 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3639 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3640 DEBUG_P(PerlIO_printf(Perl_debug_log,
3641 "Screamer: done, len=%ld, string=|%.*s|\n",
3642 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3646 /*The big, slow, and stupid way */
3651 register STDCHAR *bpe = buf + sizeof(buf);
3653 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3654 ; /* keep reading */
3658 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3659 /* Accomodate broken VAXC compiler, which applies U8 cast to
3660 * both args of ?: operator, causing EOF to change into 255
3662 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3666 sv_catpvn(sv, (char *) buf, cnt);
3668 sv_setpvn(sv, (char *) buf, cnt);
3670 if (i != EOF && /* joy */
3672 SvCUR(sv) < rslen ||
3673 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3677 * If we're reading from a TTY and we get a short read,
3678 * indicating that the user hit his EOF character, we need
3679 * to notice it now, because if we try to read from the TTY
3680 * again, the EOF condition will disappear.
3682 * The comparison of cnt to sizeof(buf) is an optimization
3683 * that prevents unnecessary calls to feof().
3687 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3692 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3693 while (i != EOF) { /* to make sure file boundaries work right */
3694 i = PerlIO_getc(fp);
3696 PerlIO_ungetc(fp,i);
3703 win32_strip_return(sv);
3706 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3711 Perl_sv_inc(pTHX_ register SV *sv)
3720 if (SvTHINKFIRST(sv)) {
3721 if (SvREADONLY(sv)) {
3723 if (PL_curcop != &PL_compiling)
3724 Perl_croak(aTHX_ PL_no_modify);
3728 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3735 flags = SvFLAGS(sv);
3736 if (flags & SVp_NOK) {
3737 (void)SvNOK_only(sv);
3741 if (flags & SVp_IOK) {
3743 if (SvUVX(sv) == UV_MAX)
3744 sv_setnv(sv, (double)UV_MAX + 1.0);
3746 (void)SvIOK_only_UV(sv);
3749 if (SvIVX(sv) == IV_MAX)
3750 sv_setnv(sv, (double)IV_MAX + 1.0);
3752 (void)SvIOK_only(sv);
3758 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3759 if ((flags & SVTYPEMASK) < SVt_PVNV)
3760 sv_upgrade(sv, SVt_NV);
3762 (void)SvNOK_only(sv);
3766 while (isALPHA(*d)) d++;
3767 while (isDIGIT(*d)) d++;
3769 SET_NUMERIC_STANDARD();
3770 sv_setnv(sv,atof(SvPVX(sv)) + 1.0); /* punt */
3774 while (d >= SvPVX(sv)) {
3782 /* MKS: The original code here died if letters weren't consecutive.
3783 * at least it didn't have to worry about non-C locales. The
3784 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3785 * arranged in order (although not consecutively) and that only
3786 * [A-Za-z] are accepted by isALPHA in the C locale.
3788 if (*d != 'z' && *d != 'Z') {
3789 do { ++*d; } while (!isALPHA(*d));
3792 *(d--) -= 'z' - 'a';
3797 *(d--) -= 'z' - 'a' + 1;
3801 /* oh,oh, the number grew */
3802 SvGROW(sv, SvCUR(sv) + 2);
3804 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3813 Perl_sv_dec(pTHX_ register SV *sv)
3821 if (SvTHINKFIRST(sv)) {
3822 if (SvREADONLY(sv)) {
3824 if (PL_curcop != &PL_compiling)
3825 Perl_croak(aTHX_ PL_no_modify);
3829 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3836 flags = SvFLAGS(sv);
3837 if (flags & SVp_NOK) {
3839 (void)SvNOK_only(sv);
3842 if (flags & SVp_IOK) {
3844 if (SvUVX(sv) == 0) {
3845 (void)SvIOK_only(sv);
3849 (void)SvIOK_only_UV(sv);
3853 if (SvIVX(sv) == IV_MIN)
3854 sv_setnv(sv, (double)IV_MIN - 1.0);
3856 (void)SvIOK_only(sv);
3862 if (!(flags & SVp_POK)) {
3863 if ((flags & SVTYPEMASK) < SVt_PVNV)
3864 sv_upgrade(sv, SVt_NV);
3866 (void)SvNOK_only(sv);
3869 SET_NUMERIC_STANDARD();
3870 sv_setnv(sv,atof(SvPVX(sv)) - 1.0); /* punt */
3873 /* Make a string that will exist for the duration of the expression
3874 * evaluation. Actually, it may have to last longer than that, but
3875 * hopefully we won't free it until it has been assigned to a
3876 * permanent location. */
3879 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3885 sv_setsv(sv,oldstr);
3887 PL_tmps_stack[++PL_tmps_ix] = sv;
3893 Perl_sv_newmortal(pTHX)
3899 SvFLAGS(sv) = SVs_TEMP;
3901 PL_tmps_stack[++PL_tmps_ix] = sv;
3905 /* same thing without the copying */
3908 Perl_sv_2mortal(pTHX_ register SV *sv)
3913 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3916 PL_tmps_stack[++PL_tmps_ix] = sv;
3922 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3929 sv_setpvn(sv,s,len);
3934 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3939 sv_setpvn(sv,s,len);
3943 #if defined(PERL_IMPLICIT_CONTEXT)
3945 Perl_newSVpvf_nocontext(const char* pat, ...)
3952 va_start(args, pat);
3953 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3960 Perl_newSVpvf(pTHX_ const char* pat, ...)
3966 va_start(args, pat);
3967 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3973 Perl_newSVnv(pTHX_ double n)
3983 Perl_newSViv(pTHX_ IV i)
3993 Perl_newRV_noinc(pTHX_ SV *tmpRef)
3999 sv_upgrade(sv, SVt_RV);
4007 Perl_newRV(pTHX_ SV *tmpRef)
4009 return newRV_noinc(SvREFCNT_inc(tmpRef));
4012 /* make an exact duplicate of old */
4015 Perl_newSVsv(pTHX_ register SV *old)
4021 if (SvTYPE(old) == SVTYPEMASK) {
4022 Perl_warn(aTHX_ "semi-panic: attempt to dup freed string");
4037 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4050 if (!*s) { /* reset ?? searches */
4051 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4052 pm->op_pmdynflags &= ~PMdf_USED;
4057 /* reset variables */
4059 if (!HvARRAY(stash))
4062 Zero(todo, 256, char);
4069 for ( ; i <= max; i++) {
4072 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4073 for (entry = HvARRAY(stash)[i];
4075 entry = HeNEXT(entry))
4077 if (!todo[(U8)*HeKEY(entry)])
4079 gv = (GV*)HeVAL(entry);
4081 if (SvTHINKFIRST(sv)) {
4082 if (!SvREADONLY(sv) && SvROK(sv))
4087 if (SvTYPE(sv) >= SVt_PV) {
4089 if (SvPVX(sv) != Nullch)
4096 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4098 #ifndef VMS /* VMS has no environ array */
4100 environ[0] = Nullch;
4109 Perl_sv_2io(pTHX_ SV *sv)
4115 switch (SvTYPE(sv)) {
4123 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4127 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4129 return sv_2io(SvRV(sv));
4130 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4136 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4143 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4150 return *gvp = Nullgv, Nullcv;
4151 switch (SvTYPE(sv)) {
4171 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4172 tryAMAGICunDEREF(to_cv);
4175 if (SvTYPE(sv) == SVt_PVCV) {
4184 Perl_croak(aTHX_ "Not a subroutine reference");
4189 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4195 if (lref && !GvCVu(gv)) {
4198 tmpsv = NEWSV(704,0);
4199 gv_efullname3(tmpsv, gv, Nullch);
4200 /* XXX this is probably not what they think they're getting.
4201 * It has the same effect as "sub name;", i.e. just a forward
4203 newSUB(start_subparse(FALSE, 0),
4204 newSVOP(OP_CONST, 0, tmpsv),
4209 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4216 Perl_sv_true(pTHX_ register SV *sv)
4223 if ((tXpv = (XPV*)SvANY(sv)) &&
4224 (*tXpv->xpv_pv > '0' ||
4225 tXpv->xpv_cur > 1 ||
4226 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4233 return SvIVX(sv) != 0;
4236 return SvNVX(sv) != 0.0;
4238 return sv_2bool(sv);
4244 Perl_sv_iv(pTHX_ register SV *sv)
4248 return (IV)SvUVX(sv);
4255 Perl_sv_uv(pTHX_ register SV *sv)
4260 return (UV)SvIVX(sv);
4266 Perl_sv_nv(pTHX_ register SV *sv)
4274 Perl_sv_pv(pTHX_ SV *sv)
4281 return sv_2pv(sv, &n_a);
4285 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4291 return sv_2pv(sv, lp);
4295 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4299 if (SvTHINKFIRST(sv) && !SvROK(sv))
4300 sv_force_normal(sv);
4306 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4308 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4309 PL_op_name[PL_op->op_type]);
4313 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4318 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4319 SvGROW(sv, len + 1);
4320 Move(s,SvPVX(sv),len,char);
4325 SvPOK_on(sv); /* validate pointer */
4327 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4328 (unsigned long)sv,SvPVX(sv)));
4335 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4337 if (ob && SvOBJECT(sv))
4338 return HvNAME(SvSTASH(sv));
4340 switch (SvTYPE(sv)) {
4354 case SVt_PVLV: return "LVALUE";
4355 case SVt_PVAV: return "ARRAY";
4356 case SVt_PVHV: return "HASH";
4357 case SVt_PVCV: return "CODE";
4358 case SVt_PVGV: return "GLOB";
4359 case SVt_PVFM: return "FORMAT";
4360 default: return "UNKNOWN";
4366 Perl_sv_isobject(pTHX_ SV *sv)
4381 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4393 return strEQ(HvNAME(SvSTASH(sv)), name);
4397 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4404 SV_CHECK_THINKFIRST(rv);
4407 if (SvTYPE(rv) < SVt_RV)
4408 sv_upgrade(rv, SVt_RV);
4415 HV* stash = gv_stashpv(classname, TRUE);
4416 (void)sv_bless(rv, stash);
4422 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4425 sv_setsv(rv, &PL_sv_undef);
4429 sv_setiv(newSVrv(rv,classname), (IV)pv);
4434 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4436 sv_setiv(newSVrv(rv,classname), iv);
4441 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, double nv)
4443 sv_setnv(newSVrv(rv,classname), nv);
4448 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4450 sv_setpvn(newSVrv(rv,classname), pv, n);
4455 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4460 Perl_croak(aTHX_ "Can't bless non-reference value");
4462 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4463 if (SvREADONLY(tmpRef))
4464 Perl_croak(aTHX_ PL_no_modify);
4465 if (SvOBJECT(tmpRef)) {
4466 if (SvTYPE(tmpRef) != SVt_PVIO)
4468 SvREFCNT_dec(SvSTASH(tmpRef));
4471 SvOBJECT_on(tmpRef);
4472 if (SvTYPE(tmpRef) != SVt_PVIO)
4474 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4475 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4486 S_sv_unglob(pTHX_ SV *sv)
4488 assert(SvTYPE(sv) == SVt_PVGV);
4493 SvREFCNT_dec(GvSTASH(sv));
4494 GvSTASH(sv) = Nullhv;
4496 sv_unmagic(sv, '*');
4497 Safefree(GvNAME(sv));
4499 SvFLAGS(sv) &= ~SVTYPEMASK;
4500 SvFLAGS(sv) |= SVt_PVMG;
4504 Perl_sv_unref(pTHX_ SV *sv)
4508 if (SvWEAKREF(sv)) {
4516 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4519 sv_2mortal(rv); /* Schedule for freeing later */
4523 Perl_sv_taint(pTHX_ SV *sv)
4525 sv_magic((sv), Nullsv, 't', Nullch, 0);
4529 Perl_sv_untaint(pTHX_ SV *sv)
4531 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4532 MAGIC *mg = mg_find(sv, 't');
4539 Perl_sv_tainted(pTHX_ SV *sv)
4541 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4542 MAGIC *mg = mg_find(sv, 't');
4543 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4550 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4552 char buf[TYPE_CHARS(UV)];
4554 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4556 sv_setpvn(sv, ptr, ebuf - ptr);
4561 Perl_sv_setpviv_mg(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);
4571 #if defined(PERL_IMPLICIT_CONTEXT)
4573 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4577 va_start(args, pat);
4578 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4584 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4588 va_start(args, pat);
4589 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4596 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4599 va_start(args, pat);
4600 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4606 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4609 va_start(args, pat);
4610 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4615 #if defined(PERL_IMPLICIT_CONTEXT)
4617 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4621 va_start(args, pat);
4622 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4627 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4631 va_start(args, pat);
4632 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4639 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4642 va_start(args, pat);
4643 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4648 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4651 va_start(args, pat);
4652 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4658 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4660 sv_setpvn(sv, "", 0);
4661 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4665 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4673 static char nullstr[] = "(null)";
4675 /* no matter what, this is a string now */
4676 (void)SvPV_force(sv, origlen);
4678 /* special-case "", "%s", and "%_" */
4681 if (patlen == 2 && pat[0] == '%') {
4685 char *s = va_arg(*args, char*);
4686 sv_catpv(sv, s ? s : nullstr);
4688 else if (svix < svmax)
4689 sv_catsv(sv, *svargs);
4693 sv_catsv(sv, va_arg(*args, SV*));
4696 /* See comment on '_' below */
4701 patend = (char*)pat + patlen;
4702 for (p = (char*)pat; p < patend; p = q) {
4710 bool has_precis = FALSE;
4715 STRLEN esignlen = 0;
4717 char *eptr = Nullch;
4719 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4730 for (q = p; q < patend && *q != '%'; ++q) ;
4732 sv_catpvn(sv, p, q - p);
4770 case '1': case '2': case '3':
4771 case '4': case '5': case '6':
4772 case '7': case '8': case '9':
4775 width = width * 10 + (*q++ - '0');
4780 i = va_arg(*args, int);
4782 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4784 width = (i < 0) ? -i : i;
4795 i = va_arg(*args, int);
4797 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4798 precis = (i < 0) ? 0 : i;
4804 precis = precis * 10 + (*q++ - '0');
4813 #if 0 /* when quads have better support within Perl */
4814 if (*(q + 1) == 'l') {
4841 uv = va_arg(*args, int);
4843 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4845 eptr = (char*)utf8buf;
4846 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4850 c = va_arg(*args, int);
4852 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4859 eptr = va_arg(*args, char*);
4861 elen = strlen(eptr);
4864 elen = sizeof nullstr - 1;
4867 else if (svix < svmax) {
4868 eptr = SvPVx(svargs[svix++], elen);
4870 if (has_precis && precis < elen) {
4872 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4875 if (width) { /* fudge width (can't fudge elen) */
4876 width += elen - sv_len_utf8(svargs[svix - 1]);
4884 * The "%_" hack might have to be changed someday,
4885 * if ISO or ANSI decide to use '_' for something.
4886 * So we keep it hidden from users' code.
4890 eptr = SvPVx(va_arg(*args, SV*), elen);
4893 if (has_precis && elen > precis)
4901 uv = (UV)va_arg(*args, void*);
4903 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4914 case 'h': iv = (short)va_arg(*args, int); break;
4915 default: iv = va_arg(*args, int); break;
4916 case 'l': iv = va_arg(*args, long); break;
4917 case 'V': iv = va_arg(*args, IV); break;
4921 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4923 case 'h': iv = (short)iv; break;
4924 default: iv = (int)iv; break;
4925 case 'l': iv = (long)iv; break;
4932 esignbuf[esignlen++] = plus;
4936 esignbuf[esignlen++] = '-';
4966 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
4967 default: uv = va_arg(*args, unsigned); break;
4968 case 'l': uv = va_arg(*args, unsigned long); break;
4969 case 'V': uv = va_arg(*args, UV); break;
4973 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
4975 case 'h': uv = (unsigned short)uv; break;
4976 default: uv = (unsigned)uv; break;
4977 case 'l': uv = (unsigned long)uv; break;
4983 eptr = ebuf + sizeof ebuf;
4989 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
4995 esignbuf[esignlen++] = '0';
4996 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5002 *--eptr = '0' + dig;
5004 if (alt && *eptr != '0')
5010 *--eptr = '0' + dig;
5012 if (alt && *eptr != '0')
5015 default: /* it had better be ten or less */
5018 *--eptr = '0' + dig;
5019 } while (uv /= base);
5022 elen = (ebuf + sizeof ebuf) - eptr;
5025 zeros = precis - elen;
5026 else if (precis == 0 && elen == 1 && *eptr == '0')
5031 /* FLOATING POINT */
5034 c = 'f'; /* maybe %F isn't supported here */
5040 /* This is evil, but floating point is even more evil */
5043 nv = va_arg(*args, double);
5045 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5048 if (c != 'e' && c != 'E') {
5050 (void)frexp(nv, &i);
5051 if (i == PERL_INT_MIN)
5052 Perl_die(aTHX_ "panic: frexp");
5054 need = BIT_DIGITS(i);
5056 need += has_precis ? precis : 6; /* known default */
5060 need += 20; /* fudge factor */
5061 if (PL_efloatsize < need) {
5062 Safefree(PL_efloatbuf);
5063 PL_efloatsize = need + 20; /* more fudge */
5064 New(906, PL_efloatbuf, PL_efloatsize, char);
5067 eptr = ebuf + sizeof ebuf;
5072 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5077 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5089 (void)sprintf(PL_efloatbuf, eptr, nv);
5091 eptr = PL_efloatbuf;
5092 elen = strlen(PL_efloatbuf);
5096 * User-defined locales may include arbitrary characters.
5097 * And, unfortunately, some system may alloc the "C" locale
5098 * to be overridden by a malicious user.
5101 *used_locale = TRUE;
5102 #endif /* LC_NUMERIC */
5109 i = SvCUR(sv) - origlen;
5112 case 'h': *(va_arg(*args, short*)) = i; break;
5113 default: *(va_arg(*args, int*)) = i; break;
5114 case 'l': *(va_arg(*args, long*)) = i; break;
5115 case 'V': *(va_arg(*args, IV*)) = i; break;
5118 else if (svix < svmax)
5119 sv_setuv(svargs[svix++], (UV)i);
5120 continue; /* not "break" */
5126 if (!args && ckWARN(WARN_PRINTF) &&
5127 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5128 SV *msg = sv_newmortal();
5129 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5130 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5132 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5135 sv_catpv(msg, "end of string");
5136 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5139 /* output mangled stuff ... */
5145 /* ... right here, because formatting flags should not apply */
5146 SvGROW(sv, SvCUR(sv) + elen + 1);
5148 memcpy(p, eptr, elen);
5151 SvCUR(sv) = p - SvPVX(sv);
5152 continue; /* not "break" */
5155 have = esignlen + zeros + elen;
5156 need = (have > width ? have : width);
5159 SvGROW(sv, SvCUR(sv) + need + 1);
5161 if (esignlen && fill == '0') {
5162 for (i = 0; i < esignlen; i++)
5166 memset(p, fill, gap);
5169 if (esignlen && fill != '0') {
5170 for (i = 0; i < esignlen; i++)
5174 for (i = zeros; i; i--)
5178 memcpy(p, eptr, elen);
5182 memset(p, ' ', gap);
5186 SvCUR(sv) = p - SvPVX(sv);