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 = *(NV**)xnv;
445 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
449 S_del_xnv(pTHX_ XPVNV *p)
451 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
453 *(NV**)xnv = PL_xnv_root;
463 New(711, xnv, 1008/sizeof(NV), NV);
464 xnvend = &xnv[1008 / sizeof(NV) - 1];
465 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
467 while (xnv < xnvend) {
468 *(NV**)xnv = (NV*)(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)) {
665 else if (mt < SVt_PVIV)
682 pv = (char*)SvRV(sv);
686 nv = (NV)(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, NV 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, NV 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) < (NV)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 #if defined(USE_LONG_DOUBLE)
1221 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1222 (unsigned long)sv, SvNVX(sv)));
1224 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1225 (unsigned long)sv, SvNVX(sv)));
1227 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1228 SvIVX(sv) = I_V(SvNVX(sv));
1230 SvUVX(sv) = U_V(SvNVX(sv));
1236 /* The NV may be reconstructed from IV - safe to cache IV,
1237 which may be calculated by atol(). */
1238 if (SvTYPE(sv) == SVt_PV)
1239 sv_upgrade(sv, SVt_PVIV);
1241 SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
1243 else { /* Not a number. Cache 0. */
1246 if (SvTYPE(sv) < SVt_PVIV)
1247 sv_upgrade(sv, SVt_PVIV);
1250 if (ckWARN(WARN_NUMERIC))
1256 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1257 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1258 if (SvTYPE(sv) < SVt_IV)
1259 /* Typically the caller expects that sv_any is not NULL now. */
1260 sv_upgrade(sv, SVt_IV);
1263 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1264 (unsigned long)sv,(long)SvIVX(sv)));
1265 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1269 Perl_sv_2uv(pTHX_ register SV *sv)
1273 if (SvGMAGICAL(sv)) {
1278 return U_V(SvNVX(sv));
1279 if (SvPOKp(sv) && SvLEN(sv))
1282 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1284 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1285 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1290 if (SvTHINKFIRST(sv)) {
1293 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1294 return SvUV(tmpstr);
1295 return (UV)SvRV(sv);
1297 if (SvREADONLY(sv)) {
1299 return U_V(SvNVX(sv));
1301 if (SvPOKp(sv) && SvLEN(sv))
1305 if (ckWARN(WARN_UNINITIALIZED))
1306 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1316 return (UV)SvIVX(sv);
1320 /* We can cache the IV/UV value even if it not good enough
1321 * to reconstruct NV, since the conversion to PV will prefer
1322 * NV over IV/UV. XXXX 64-bit?
1324 if (SvTYPE(sv) == SVt_NV)
1325 sv_upgrade(sv, SVt_PVNV);
1327 if (SvNVX(sv) >= -0.5) {
1329 SvUVX(sv) = U_V(SvNVX(sv));
1332 SvIVX(sv) = I_V(SvNVX(sv));
1334 DEBUG_c(PerlIO_printf(Perl_debug_log,
1335 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1336 (unsigned long)sv,(long)SvIVX(sv),
1337 (long)(UV)SvIVX(sv)));
1338 return (UV)SvIVX(sv);
1341 else if (SvPOKp(sv) && SvLEN(sv)) {
1342 I32 numtype = looks_like_number(sv);
1344 /* We want to avoid a possible problem when we cache a UV which
1345 may be later translated to an NV, and the resulting NV is not
1346 the translation of the initial data.
1348 This means that if we cache such a UV, we need to cache the
1349 NV as well. Moreover, we trade speed for space, and do not
1350 cache the NV if not needed.
1352 if (numtype & IS_NUMBER_NOT_IV) {
1353 /* May be not an integer. Need to cache NV if we cache IV
1354 * - otherwise future conversion to NV will be wrong. */
1357 d = Atof(SvPVX(sv)); /* XXXX 64-bit? */
1359 if (SvTYPE(sv) < SVt_PVNV)
1360 sv_upgrade(sv, SVt_PVNV);
1364 #if defined(USE_LONG_DOUBLE)
1365 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1366 (unsigned long)sv, SvNVX(sv)));
1368 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1369 (unsigned long)sv, SvNVX(sv)));
1371 if (SvNVX(sv) < -0.5) {
1372 SvIVX(sv) = I_V(SvNVX(sv));
1375 SvUVX(sv) = U_V(SvNVX(sv));
1379 else if (numtype & IS_NUMBER_NEG) {
1380 /* The NV may be reconstructed from IV - safe to cache IV,
1381 which may be calculated by atol(). */
1382 if (SvTYPE(sv) == SVt_PV)
1383 sv_upgrade(sv, SVt_PVIV);
1385 SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1387 else if (numtype) { /* Non-negative */
1388 /* The NV may be reconstructed from UV - safe to cache UV,
1389 which may be calculated by strtoul()/atol. */
1390 if (SvTYPE(sv) == SVt_PV)
1391 sv_upgrade(sv, SVt_PVIV);
1393 (void)SvIsUV_on(sv);
1395 SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
1396 #else /* no atou(), but we know the number fits into IV... */
1397 /* The only problem may be if it is negative... */
1398 SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1401 else { /* Not a number. Cache 0. */
1404 if (SvTYPE(sv) < SVt_PVIV)
1405 sv_upgrade(sv, SVt_PVIV);
1406 SvUVX(sv) = 0; /* We assume that 0s have the
1407 same bitmap in IV and UV. */
1409 (void)SvIsUV_on(sv);
1410 if (ckWARN(WARN_NUMERIC))
1415 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1417 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1418 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1420 if (SvTYPE(sv) < SVt_IV)
1421 /* Typically the caller expects that sv_any is not NULL now. */
1422 sv_upgrade(sv, SVt_IV);
1426 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1427 (unsigned long)sv,SvUVX(sv)));
1428 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1432 Perl_sv_2nv(pTHX_ register SV *sv)
1436 if (SvGMAGICAL(sv)) {
1440 if (SvPOKp(sv) && SvLEN(sv)) {
1442 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1444 return Atof(SvPVX(sv));
1448 return (NV)SvUVX(sv);
1450 return (NV)SvIVX(sv);
1453 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1455 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1456 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1461 if (SvTHINKFIRST(sv)) {
1464 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1465 return SvNV(tmpstr);
1466 return (NV)(unsigned long)SvRV(sv);
1468 if (SvREADONLY(sv)) {
1470 if (SvPOKp(sv) && SvLEN(sv)) {
1471 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1473 return Atof(SvPVX(sv));
1477 return (NV)SvUVX(sv);
1479 return (NV)SvIVX(sv);
1481 if (ckWARN(WARN_UNINITIALIZED))
1482 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1486 if (SvTYPE(sv) < SVt_NV) {
1487 if (SvTYPE(sv) == SVt_IV)
1488 sv_upgrade(sv, SVt_PVNV);
1490 sv_upgrade(sv, SVt_NV);
1491 #if defined(USE_LONG_DOUBLE)
1493 RESTORE_NUMERIC_STANDARD();
1494 PerlIO_printf(Perl_debug_log, "0x%lx num(%Lg)\n",
1495 (unsigned long)sv, SvNVX(sv));
1496 RESTORE_NUMERIC_LOCAL();
1500 RESTORE_NUMERIC_STANDARD();
1501 PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
1502 (unsigned long)sv, SvNVX(sv));
1503 RESTORE_NUMERIC_LOCAL();
1507 else if (SvTYPE(sv) < SVt_PVNV)
1508 sv_upgrade(sv, SVt_PVNV);
1510 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1512 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1514 else if (SvPOKp(sv) && SvLEN(sv)) {
1516 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1518 SvNVX(sv) = Atof(SvPVX(sv));
1522 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1523 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1524 if (SvTYPE(sv) < SVt_NV)
1525 /* Typically the caller expects that sv_any is not NULL now. */
1526 sv_upgrade(sv, SVt_NV);
1530 #if defined(USE_LONG_DOUBLE)
1532 RESTORE_NUMERIC_STANDARD();
1533 PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1534 (unsigned long)sv, SvNVX(sv));
1535 RESTORE_NUMERIC_LOCAL();
1539 RESTORE_NUMERIC_STANDARD();
1540 PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
1541 (unsigned long)sv, SvNVX(sv));
1542 RESTORE_NUMERIC_LOCAL();
1549 S_asIV(pTHX_ SV *sv)
1551 I32 numtype = looks_like_number(sv);
1554 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1555 return atol(SvPVX(sv)); /* XXXX 64-bit? */
1558 if (ckWARN(WARN_NUMERIC))
1561 d = Atof(SvPVX(sv));
1566 S_asUV(pTHX_ SV *sv)
1568 I32 numtype = looks_like_number(sv);
1571 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1572 return strtoul(SvPVX(sv), Null(char**), 10);
1576 if (ckWARN(WARN_NUMERIC))
1579 return U_V(Atof(SvPVX(sv)));
1583 * Returns a combination of (advisory only - can get false negatives)
1584 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1586 * 0 if does not look like number.
1588 * In fact possible values are 0 and
1589 * IS_NUMBER_TO_INT_BY_ATOL 123
1590 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1591 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1592 * with a possible addition of IS_NUMBER_NEG.
1596 Perl_looks_like_number(pTHX_ SV *sv)
1598 /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
1599 * using atof() may lose precision. */
1601 register char *send;
1602 register char *sbegin;
1603 register char *nbegin;
1611 else if (SvPOKp(sv))
1612 sbegin = SvPV(sv, len);
1615 send = sbegin + len;
1622 numtype = IS_NUMBER_NEG;
1629 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1630 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1634 /* next must be digit or the radix separator */
1638 } while (isDIGIT(*s));
1640 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1641 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1643 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1646 #ifdef USE_LOCALE_NUMERIC
1647 || IS_NUMERIC_RADIX(*s)
1651 numtype |= IS_NUMBER_NOT_IV;
1652 while (isDIGIT(*s)) /* optional digits after the radix */
1657 #ifdef USE_LOCALE_NUMERIC
1658 || IS_NUMERIC_RADIX(*s)
1662 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1663 /* no digits before the radix means we need digits after it */
1667 } while (isDIGIT(*s));
1675 /* we can have an optional exponent part */
1676 if (*s == 'e' || *s == 'E') {
1677 numtype &= ~IS_NUMBER_NEG;
1678 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1680 if (*s == '+' || *s == '-')
1685 } while (isDIGIT(*s));
1694 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1695 return IS_NUMBER_TO_INT_BY_ATOL;
1700 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1703 return sv_2pv(sv, &n_a);
1706 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1708 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1711 char *ptr = buf + TYPE_CHARS(UV);
1726 *--ptr = '0' + (uv % 10);
1735 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1740 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1741 char *tmpbuf = tbuf;
1747 if (SvGMAGICAL(sv)) {
1753 if (SvIOKp(sv)) { /* XXXX 64-bit? */
1755 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1757 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1762 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1767 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1769 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1770 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1776 if (SvTHINKFIRST(sv)) {
1779 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1780 return SvPV(tmpstr,*lp);
1787 switch (SvTYPE(sv)) {
1789 if ( ((SvFLAGS(sv) &
1790 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1791 == (SVs_OBJECT|SVs_RMG))
1792 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1793 && (mg = mg_find(sv, 'r'))) {
1795 regexp *re = (regexp *)mg->mg_obj;
1798 char *fptr = "msix";
1803 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1805 while(ch = *fptr++) {
1807 reflags[left++] = ch;
1810 reflags[right--] = ch;
1815 reflags[left] = '-';
1819 mg->mg_len = re->prelen + 4 + left;
1820 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1821 Copy("(?", mg->mg_ptr, 2, char);
1822 Copy(reflags, mg->mg_ptr+2, left, char);
1823 Copy(":", mg->mg_ptr+left+2, 1, char);
1824 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1825 mg->mg_ptr[mg->mg_len - 1] = ')';
1826 mg->mg_ptr[mg->mg_len] = 0;
1828 PL_reginterp_cnt += re->program[0].next_off;
1840 case SVt_PVBM: s = "SCALAR"; break;
1841 case SVt_PVLV: s = "LVALUE"; break;
1842 case SVt_PVAV: s = "ARRAY"; break;
1843 case SVt_PVHV: s = "HASH"; break;
1844 case SVt_PVCV: s = "CODE"; break;
1845 case SVt_PVGV: s = "GLOB"; break;
1846 case SVt_PVFM: s = "FORMAT"; break;
1847 case SVt_PVIO: s = "IO"; break;
1848 default: s = "UNKNOWN"; break;
1852 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1856 Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
1862 if (SvREADONLY(sv)) {
1863 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1864 /* XXXX 64-bit? IV may have better precision... */
1865 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1873 tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
1875 tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
1882 if (ckWARN(WARN_UNINITIALIZED))
1883 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1889 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1890 /* XXXX 64-bit? IV may have better precision... */
1891 if (SvTYPE(sv) < SVt_PVNV)
1892 sv_upgrade(sv, SVt_PVNV);
1895 olderrno = errno; /* some Xenix systems wipe out errno here */
1897 if (SvNVX(sv) == 0.0)
1898 (void)strcpy(s,"0");
1902 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1905 #ifdef FIXNEGATIVEZERO
1906 if (*s == '-' && s[1] == '0' && !s[2])
1915 else if (SvIOKp(sv)) {
1916 U32 isIOK = SvIOK(sv);
1917 char buf[TYPE_CHARS(UV)];
1920 if (SvTYPE(sv) < SVt_PVIV)
1921 sv_upgrade(sv, SVt_PVIV);
1923 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1924 sv_setpvn(sv, ptr, ebuf - ptr);
1928 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1929 sv_setpvn(sv, ptr, ebuf - ptr);
1939 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1940 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1942 if (SvTYPE(sv) < SVt_PV)
1943 /* Typically the caller expects that sv_any is not NULL now. */
1944 sv_upgrade(sv, SVt_PV);
1947 *lp = s - SvPVX(sv);
1950 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1954 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1955 /* Sneaky stuff here */
1959 tsv = newSVpv(tmpbuf, 0);
1975 len = strlen(tmpbuf);
1977 #ifdef FIXNEGATIVEZERO
1978 if (len == 2 && t[0] == '-' && t[1] == '0') {
1983 (void)SvUPGRADE(sv, SVt_PV);
1985 s = SvGROW(sv, len + 1);
1993 /* This function is only called on magical items */
1995 Perl_sv_2bool(pTHX_ register SV *sv)
2005 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2006 return SvTRUE(tmpsv);
2007 return SvRV(sv) != 0;
2010 register XPV* Xpvtmp;
2011 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2012 (*Xpvtmp->xpv_pv > '0' ||
2013 Xpvtmp->xpv_cur > 1 ||
2014 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2021 return SvIVX(sv) != 0;
2024 return SvNVX(sv) != 0.0;
2031 /* Note: sv_setsv() should not be called with a source string that needs
2032 * to be reused, since it may destroy the source string if it is marked
2037 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2040 register U32 sflags;
2046 SV_CHECK_THINKFIRST(dstr);
2048 sstr = &PL_sv_undef;
2049 stype = SvTYPE(sstr);
2050 dtype = SvTYPE(dstr);
2054 /* There's a lot of redundancy below but we're going for speed here */
2059 if (dtype != SVt_PVGV) {
2060 (void)SvOK_off(dstr);
2068 sv_upgrade(dstr, SVt_IV);
2071 sv_upgrade(dstr, SVt_PVNV);
2075 sv_upgrade(dstr, SVt_PVIV);
2078 (void)SvIOK_only(dstr);
2079 SvIVX(dstr) = SvIVX(sstr);
2092 sv_upgrade(dstr, SVt_NV);
2097 sv_upgrade(dstr, SVt_PVNV);
2100 SvNVX(dstr) = SvNVX(sstr);
2101 (void)SvNOK_only(dstr);
2109 sv_upgrade(dstr, SVt_RV);
2110 else if (dtype == SVt_PVGV &&
2111 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2114 if (PL_curcop->cop_stash != GvSTASH(dstr))
2115 GvIMPORTED_on(dstr);
2125 sv_upgrade(dstr, SVt_PV);
2128 if (dtype < SVt_PVIV)
2129 sv_upgrade(dstr, SVt_PVIV);
2132 if (dtype < SVt_PVNV)
2133 sv_upgrade(dstr, SVt_PVNV);
2140 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2141 PL_op_name[PL_op->op_type]);
2143 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2147 if (dtype <= SVt_PVGV) {
2149 if (dtype != SVt_PVGV) {
2150 char *name = GvNAME(sstr);
2151 STRLEN len = GvNAMELEN(sstr);
2152 sv_upgrade(dstr, SVt_PVGV);
2153 sv_magic(dstr, dstr, '*', name, len);
2154 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2155 GvNAME(dstr) = savepvn(name, len);
2156 GvNAMELEN(dstr) = len;
2157 SvFAKE_on(dstr); /* can coerce to non-glob */
2159 /* ahem, death to those who redefine active sort subs */
2160 else if (PL_curstackinfo->si_type == PERLSI_SORT
2161 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2162 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2164 (void)SvOK_off(dstr);
2165 GvINTRO_off(dstr); /* one-shot flag */
2167 GvGP(dstr) = gp_ref(GvGP(sstr));
2169 if (PL_curcop->cop_stash != GvSTASH(dstr))
2170 GvIMPORTED_on(dstr);
2177 if (SvGMAGICAL(sstr)) {
2179 if (SvTYPE(sstr) != stype) {
2180 stype = SvTYPE(sstr);
2181 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2185 if (stype == SVt_PVLV)
2186 (void)SvUPGRADE(dstr, SVt_PVNV);
2188 (void)SvUPGRADE(dstr, stype);
2191 sflags = SvFLAGS(sstr);
2193 if (sflags & SVf_ROK) {
2194 if (dtype >= SVt_PV) {
2195 if (dtype == SVt_PVGV) {
2196 SV *sref = SvREFCNT_inc(SvRV(sstr));
2198 int intro = GvINTRO(dstr);
2202 GvGP(dstr)->gp_refcnt--;
2203 GvINTRO_off(dstr); /* one-shot flag */
2204 Newz(602,gp, 1, GP);
2205 GvGP(dstr) = gp_ref(gp);
2206 GvSV(dstr) = NEWSV(72,0);
2207 GvLINE(dstr) = PL_curcop->cop_line;
2208 GvEGV(dstr) = (GV*)dstr;
2211 switch (SvTYPE(sref)) {
2214 SAVESPTR(GvAV(dstr));
2216 dref = (SV*)GvAV(dstr);
2217 GvAV(dstr) = (AV*)sref;
2218 if (PL_curcop->cop_stash != GvSTASH(dstr))
2219 GvIMPORTED_AV_on(dstr);
2223 SAVESPTR(GvHV(dstr));
2225 dref = (SV*)GvHV(dstr);
2226 GvHV(dstr) = (HV*)sref;
2227 if (PL_curcop->cop_stash != GvSTASH(dstr))
2228 GvIMPORTED_HV_on(dstr);
2232 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2233 SvREFCNT_dec(GvCV(dstr));
2234 GvCV(dstr) = Nullcv;
2235 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2236 PL_sub_generation++;
2238 SAVESPTR(GvCV(dstr));
2241 dref = (SV*)GvCV(dstr);
2242 if (GvCV(dstr) != (CV*)sref) {
2243 CV* cv = GvCV(dstr);
2245 if (!GvCVGEN((GV*)dstr) &&
2246 (CvROOT(cv) || CvXSUB(cv)))
2248 SV *const_sv = cv_const_sv(cv);
2249 bool const_changed = TRUE;
2251 const_changed = sv_cmp(const_sv,
2252 op_const_sv(CvSTART((CV*)sref),
2254 /* ahem, death to those who redefine
2255 * active sort subs */
2256 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2257 PL_sortcop == CvSTART(cv))
2259 "Can't redefine active sort subroutine %s",
2260 GvENAME((GV*)dstr));
2261 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2262 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2263 && HvNAME(GvSTASH(CvGV(cv)))
2264 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2266 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2267 "Constant subroutine %s redefined"
2268 : "Subroutine %s redefined",
2269 GvENAME((GV*)dstr));
2272 cv_ckproto(cv, (GV*)dstr,
2273 SvPOK(sref) ? SvPVX(sref) : Nullch);
2275 GvCV(dstr) = (CV*)sref;
2276 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2277 GvASSUMECV_on(dstr);
2278 PL_sub_generation++;
2280 if (PL_curcop->cop_stash != GvSTASH(dstr))
2281 GvIMPORTED_CV_on(dstr);
2285 SAVESPTR(GvIOp(dstr));
2287 dref = (SV*)GvIOp(dstr);
2288 GvIOp(dstr) = (IO*)sref;
2292 SAVESPTR(GvSV(dstr));
2294 dref = (SV*)GvSV(dstr);
2296 if (PL_curcop->cop_stash != GvSTASH(dstr))
2297 GvIMPORTED_SV_on(dstr);
2308 (void)SvOOK_off(dstr); /* backoff */
2310 Safefree(SvPVX(dstr));
2311 SvLEN(dstr)=SvCUR(dstr)=0;
2314 (void)SvOK_off(dstr);
2315 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2317 if (sflags & SVp_NOK) {
2319 SvNVX(dstr) = SvNVX(sstr);
2321 if (sflags & SVp_IOK) {
2322 (void)SvIOK_on(dstr);
2323 SvIVX(dstr) = SvIVX(sstr);
2327 if (SvAMAGIC(sstr)) {
2331 else if (sflags & SVp_POK) {
2334 * Check to see if we can just swipe the string. If so, it's a
2335 * possible small lose on short strings, but a big win on long ones.
2336 * It might even be a win on short strings if SvPVX(dstr)
2337 * has to be allocated and SvPVX(sstr) has to be freed.
2340 if (SvTEMP(sstr) && /* slated for free anyway? */
2341 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2342 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2344 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2346 SvFLAGS(dstr) &= ~SVf_OOK;
2347 Safefree(SvPVX(dstr) - SvIVX(dstr));
2349 else if (SvLEN(dstr))
2350 Safefree(SvPVX(dstr));
2352 (void)SvPOK_only(dstr);
2353 SvPV_set(dstr, SvPVX(sstr));
2354 SvLEN_set(dstr, SvLEN(sstr));
2355 SvCUR_set(dstr, SvCUR(sstr));
2357 (void)SvOK_off(sstr);
2358 SvPV_set(sstr, Nullch);
2363 else { /* have to copy actual string */
2364 STRLEN len = SvCUR(sstr);
2366 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2367 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2368 SvCUR_set(dstr, len);
2369 *SvEND(dstr) = '\0';
2370 (void)SvPOK_only(dstr);
2373 if (sflags & SVp_NOK) {
2375 SvNVX(dstr) = SvNVX(sstr);
2377 if (sflags & SVp_IOK) {
2378 (void)SvIOK_on(dstr);
2379 SvIVX(dstr) = SvIVX(sstr);
2384 else if (sflags & SVp_NOK) {
2385 SvNVX(dstr) = SvNVX(sstr);
2386 (void)SvNOK_only(dstr);
2388 (void)SvIOK_on(dstr);
2389 SvIVX(dstr) = SvIVX(sstr);
2390 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2395 else if (sflags & SVp_IOK) {
2396 (void)SvIOK_only(dstr);
2397 SvIVX(dstr) = SvIVX(sstr);
2402 if (dtype == SVt_PVGV) {
2403 if (ckWARN(WARN_UNSAFE))
2404 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2407 (void)SvOK_off(dstr);
2413 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2415 sv_setsv(dstr,sstr);
2420 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2422 register char *dptr;
2423 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2424 elicit a warning, but it won't hurt. */
2425 SV_CHECK_THINKFIRST(sv);
2430 (void)SvUPGRADE(sv, SVt_PV);
2432 SvGROW(sv, len + 1);
2434 Move(ptr,dptr,len,char);
2437 (void)SvPOK_only(sv); /* validate pointer */
2442 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2444 sv_setpvn(sv,ptr,len);
2449 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2451 register STRLEN len;
2453 SV_CHECK_THINKFIRST(sv);
2459 (void)SvUPGRADE(sv, SVt_PV);
2461 SvGROW(sv, len + 1);
2462 Move(ptr,SvPVX(sv),len+1,char);
2464 (void)SvPOK_only(sv); /* validate pointer */
2469 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2476 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2478 SV_CHECK_THINKFIRST(sv);
2479 (void)SvUPGRADE(sv, SVt_PV);
2484 (void)SvOOK_off(sv);
2485 if (SvPVX(sv) && SvLEN(sv))
2486 Safefree(SvPVX(sv));
2487 Renew(ptr, len+1, char);
2490 SvLEN_set(sv, len+1);
2492 (void)SvPOK_only(sv); /* validate pointer */
2497 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2499 sv_usepvn(sv,ptr,len);
2504 Perl_sv_force_normal(pTHX_ register SV *sv)
2506 if (SvREADONLY(sv)) {
2508 if (PL_curcop != &PL_compiling)
2509 Perl_croak(aTHX_ PL_no_modify);
2513 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2518 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2522 register STRLEN delta;
2524 if (!ptr || !SvPOKp(sv))
2526 SV_CHECK_THINKFIRST(sv);
2527 if (SvTYPE(sv) < SVt_PVIV)
2528 sv_upgrade(sv,SVt_PVIV);
2531 if (!SvLEN(sv)) { /* make copy of shared string */
2532 char *pvx = SvPVX(sv);
2533 STRLEN len = SvCUR(sv);
2534 SvGROW(sv, len + 1);
2535 Move(pvx,SvPVX(sv),len,char);
2539 SvFLAGS(sv) |= SVf_OOK;
2541 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2542 delta = ptr - SvPVX(sv);
2550 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2555 junk = SvPV_force(sv, tlen);
2556 SvGROW(sv, tlen + len + 1);
2559 Move(ptr,SvPVX(sv)+tlen,len,char);
2562 (void)SvPOK_only(sv); /* validate pointer */
2567 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2569 sv_catpvn(sv,ptr,len);
2574 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2580 if (s = SvPV(sstr, len))
2581 sv_catpvn(dstr,s,len);
2585 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2587 sv_catsv(dstr,sstr);
2592 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2594 register STRLEN len;
2600 junk = SvPV_force(sv, tlen);
2602 SvGROW(sv, tlen + len + 1);
2605 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2607 (void)SvPOK_only(sv); /* validate pointer */
2612 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2619 Perl_newSV(pTHX_ STRLEN len)
2625 sv_upgrade(sv, SVt_PV);
2626 SvGROW(sv, len + 1);
2631 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2634 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2638 if (SvREADONLY(sv)) {
2640 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2641 Perl_croak(aTHX_ PL_no_modify);
2643 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2644 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2651 (void)SvUPGRADE(sv, SVt_PVMG);
2653 Newz(702,mg, 1, MAGIC);
2654 mg->mg_moremagic = SvMAGIC(sv);
2657 if (!obj || obj == sv || how == '#' || how == 'r')
2661 mg->mg_obj = SvREFCNT_inc(obj);
2662 mg->mg_flags |= MGf_REFCOUNTED;
2665 mg->mg_len = namlen;
2668 mg->mg_ptr = savepvn(name, namlen);
2669 else if (namlen == HEf_SVKEY)
2670 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2674 mg->mg_virtual = &PL_vtbl_sv;
2677 mg->mg_virtual = &PL_vtbl_amagic;
2680 mg->mg_virtual = &PL_vtbl_amagicelem;
2686 mg->mg_virtual = &PL_vtbl_bm;
2689 mg->mg_virtual = &PL_vtbl_regdata;
2692 mg->mg_virtual = &PL_vtbl_regdatum;
2695 mg->mg_virtual = &PL_vtbl_env;
2698 mg->mg_virtual = &PL_vtbl_fm;
2701 mg->mg_virtual = &PL_vtbl_envelem;
2704 mg->mg_virtual = &PL_vtbl_mglob;
2707 mg->mg_virtual = &PL_vtbl_isa;
2710 mg->mg_virtual = &PL_vtbl_isaelem;
2713 mg->mg_virtual = &PL_vtbl_nkeys;
2720 mg->mg_virtual = &PL_vtbl_dbline;
2724 mg->mg_virtual = &PL_vtbl_mutex;
2726 #endif /* USE_THREADS */
2727 #ifdef USE_LOCALE_COLLATE
2729 mg->mg_virtual = &PL_vtbl_collxfrm;
2731 #endif /* USE_LOCALE_COLLATE */
2733 mg->mg_virtual = &PL_vtbl_pack;
2737 mg->mg_virtual = &PL_vtbl_packelem;
2740 mg->mg_virtual = &PL_vtbl_regexp;
2743 mg->mg_virtual = &PL_vtbl_sig;
2746 mg->mg_virtual = &PL_vtbl_sigelem;
2749 mg->mg_virtual = &PL_vtbl_taint;
2753 mg->mg_virtual = &PL_vtbl_uvar;
2756 mg->mg_virtual = &PL_vtbl_vec;
2759 mg->mg_virtual = &PL_vtbl_substr;
2762 mg->mg_virtual = &PL_vtbl_defelem;
2765 mg->mg_virtual = &PL_vtbl_glob;
2768 mg->mg_virtual = &PL_vtbl_arylen;
2771 mg->mg_virtual = &PL_vtbl_pos;
2774 mg->mg_virtual = &PL_vtbl_backref;
2776 case '~': /* Reserved for use by extensions not perl internals. */
2777 /* Useful for attaching extension internal data to perl vars. */
2778 /* Note that multiple extensions may clash if magical scalars */
2779 /* etc holding private data from one are passed to another. */
2783 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
2787 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2791 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2795 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2798 for (mg = *mgp; mg; mg = *mgp) {
2799 if (mg->mg_type == type) {
2800 MGVTBL* vtbl = mg->mg_virtual;
2801 *mgp = mg->mg_moremagic;
2802 if (vtbl && (vtbl->svt_free != NULL))
2803 (VTBL->svt_free)(aTHX_ sv, mg);
2804 if (mg->mg_ptr && mg->mg_type != 'g')
2805 if (mg->mg_len >= 0)
2806 Safefree(mg->mg_ptr);
2807 else if (mg->mg_len == HEf_SVKEY)
2808 SvREFCNT_dec((SV*)mg->mg_ptr);
2809 if (mg->mg_flags & MGf_REFCOUNTED)
2810 SvREFCNT_dec(mg->mg_obj);
2814 mgp = &mg->mg_moremagic;
2818 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2825 Perl_sv_rvweaken(pTHX_ SV *sv)
2828 if (!SvOK(sv)) /* let undefs pass */
2831 Perl_croak(aTHX_ "Can't weaken a nonreference");
2832 else if (SvWEAKREF(sv)) {
2834 if (ckWARN(WARN_MISC))
2835 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
2839 sv_add_backref(tsv, sv);
2846 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
2850 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2851 av = (AV*)mg->mg_obj;
2854 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2855 SvREFCNT_dec(av); /* for sv_magic */
2861 S_sv_del_backref(pTHX_ SV *sv)
2868 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2869 Perl_croak(aTHX_ "panic: del_backref");
2870 av = (AV *)mg->mg_obj;
2875 svp[i] = &PL_sv_undef; /* XXX */
2882 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2886 register char *midend;
2887 register char *bigend;
2893 Perl_croak(aTHX_ "Can't modify non-existent substring");
2894 SvPV_force(bigstr, curlen);
2895 if (offset + len > curlen) {
2896 SvGROW(bigstr, offset+len+1);
2897 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2898 SvCUR_set(bigstr, offset+len);
2901 i = littlelen - len;
2902 if (i > 0) { /* string might grow */
2903 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2904 mid = big + offset + len;
2905 midend = bigend = big + SvCUR(bigstr);
2908 while (midend > mid) /* shove everything down */
2909 *--bigend = *--midend;
2910 Move(little,big+offset,littlelen,char);
2916 Move(little,SvPVX(bigstr)+offset,len,char);
2921 big = SvPVX(bigstr);
2924 bigend = big + SvCUR(bigstr);
2926 if (midend > bigend)
2927 Perl_croak(aTHX_ "panic: sv_insert");
2929 if (mid - big > bigend - midend) { /* faster to shorten from end */
2931 Move(little, mid, littlelen,char);
2934 i = bigend - midend;
2936 Move(midend, mid, i,char);
2940 SvCUR_set(bigstr, mid - big);
2943 else if (i = mid - big) { /* faster from front */
2944 midend -= littlelen;
2946 sv_chop(bigstr,midend-i);
2951 Move(little, mid, littlelen,char);
2953 else if (littlelen) {
2954 midend -= littlelen;
2955 sv_chop(bigstr,midend);
2956 Move(little,midend,littlelen,char);
2959 sv_chop(bigstr,midend);
2964 /* make sv point to what nstr did */
2967 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2969 U32 refcnt = SvREFCNT(sv);
2970 SV_CHECK_THINKFIRST(sv);
2971 if (SvREFCNT(nsv) != 1)
2972 Perl_warn(aTHX_ "Reference miscount in sv_replace()");
2973 if (SvMAGICAL(sv)) {
2977 sv_upgrade(nsv, SVt_PVMG);
2978 SvMAGIC(nsv) = SvMAGIC(sv);
2979 SvFLAGS(nsv) |= SvMAGICAL(sv);
2985 assert(!SvREFCNT(sv));
2986 StructCopy(nsv,sv,SV);
2987 SvREFCNT(sv) = refcnt;
2988 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2993 Perl_sv_clear(pTHX_ register SV *sv)
2997 assert(SvREFCNT(sv) == 0);
3001 if (PL_defstash) { /* Still have a symbol table? */
3006 Zero(&tmpref, 1, SV);
3007 sv_upgrade(&tmpref, SVt_RV);
3009 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3010 SvREFCNT(&tmpref) = 1;
3013 stash = SvSTASH(sv);
3014 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3017 PUSHSTACKi(PERLSI_DESTROY);
3018 SvRV(&tmpref) = SvREFCNT_inc(sv);
3023 call_sv((SV*)GvCV(destructor),
3024 G_DISCARD|G_EVAL|G_KEEPERR);
3030 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3032 del_XRV(SvANY(&tmpref));
3035 if (PL_in_clean_objs)
3036 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3038 /* DESTROY gave object new lease on life */
3044 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3045 SvOBJECT_off(sv); /* Curse the object. */
3046 if (SvTYPE(sv) != SVt_PVIO)
3047 --PL_sv_objcount; /* XXX Might want something more general */
3050 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3053 switch (SvTYPE(sv)) {
3056 IoIFP(sv) != PerlIO_stdin() &&
3057 IoIFP(sv) != PerlIO_stdout() &&
3058 IoIFP(sv) != PerlIO_stderr())
3063 PerlDir_close(IoDIRP(sv));
3066 Safefree(IoTOP_NAME(sv));
3067 Safefree(IoFMT_NAME(sv));
3068 Safefree(IoBOTTOM_NAME(sv));
3083 SvREFCNT_dec(LvTARG(sv));
3087 Safefree(GvNAME(sv));
3088 /* cannot decrease stash refcount yet, as we might recursively delete
3089 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3090 of stash until current sv is completely gone.
3091 -- JohnPC, 27 Mar 1998 */
3092 stash = GvSTASH(sv);
3098 (void)SvOOK_off(sv);
3106 SvREFCNT_dec(SvRV(sv));
3108 else if (SvPVX(sv) && SvLEN(sv))
3109 Safefree(SvPVX(sv));
3119 switch (SvTYPE(sv)) {
3135 del_XPVIV(SvANY(sv));
3138 del_XPVNV(SvANY(sv));
3141 del_XPVMG(SvANY(sv));
3144 del_XPVLV(SvANY(sv));
3147 del_XPVAV(SvANY(sv));
3150 del_XPVHV(SvANY(sv));
3153 del_XPVCV(SvANY(sv));
3156 del_XPVGV(SvANY(sv));
3157 /* code duplication for increased performance. */
3158 SvFLAGS(sv) &= SVf_BREAK;
3159 SvFLAGS(sv) |= SVTYPEMASK;
3160 /* decrease refcount of the stash that owns this GV, if any */
3162 SvREFCNT_dec(stash);
3163 return; /* not break, SvFLAGS reset already happened */
3165 del_XPVBM(SvANY(sv));
3168 del_XPVFM(SvANY(sv));
3171 del_XPVIO(SvANY(sv));
3174 SvFLAGS(sv) &= SVf_BREAK;
3175 SvFLAGS(sv) |= SVTYPEMASK;
3179 Perl_sv_newref(pTHX_ SV *sv)
3182 ATOMIC_INC(SvREFCNT(sv));
3187 Perl_sv_free(pTHX_ SV *sv)
3189 int refcount_is_zero;
3193 if (SvREFCNT(sv) == 0) {
3194 if (SvFLAGS(sv) & SVf_BREAK)
3196 if (PL_in_clean_all) /* All is fair */
3198 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3199 /* make sure SvREFCNT(sv)==0 happens very seldom */
3200 SvREFCNT(sv) = (~(U32)0)/2;
3203 Perl_warn(aTHX_ "Attempt to free unreferenced scalar");
3206 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3207 if (!refcount_is_zero)
3211 Perl_warn(aTHX_ "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3215 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3216 /* make sure SvREFCNT(sv)==0 happens very seldom */
3217 SvREFCNT(sv) = (~(U32)0)/2;
3226 Perl_sv_len(pTHX_ register SV *sv)
3235 len = mg_length(sv);
3237 junk = SvPV(sv, len);
3242 Perl_sv_len_utf8(pTHX_ register SV *sv)
3253 len = mg_length(sv);
3256 s = (U8*)SvPV(sv, len);
3267 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3272 I32 uoffset = *offsetp;
3278 start = s = (U8*)SvPV(sv, len);
3280 while (s < send && uoffset--)
3284 *offsetp = s - start;
3288 while (s < send && ulen--)
3298 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3307 s = (U8*)SvPV(sv, len);
3309 Perl_croak(aTHX_ "panic: bad byte offset");
3310 send = s + *offsetp;
3317 Perl_warn(aTHX_ "Malformed UTF-8 character");
3325 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3337 pv1 = SvPV(str1, cur1);
3342 pv2 = SvPV(str2, cur2);
3347 return memEQ(pv1, pv2, cur1);
3351 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3354 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3356 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3360 return cur2 ? -1 : 0;
3365 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3368 return retval < 0 ? -1 : 1;
3373 return cur1 < cur2 ? -1 : 1;
3377 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3379 #ifdef USE_LOCALE_COLLATE
3385 if (PL_collation_standard)
3389 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3391 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3393 if (!pv1 || !len1) {
3404 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3407 return retval < 0 ? -1 : 1;
3410 * When the result of collation is equality, that doesn't mean
3411 * that there are no differences -- some locales exclude some
3412 * characters from consideration. So to avoid false equalities,
3413 * we use the raw string as a tiebreaker.
3419 #endif /* USE_LOCALE_COLLATE */
3421 return sv_cmp(sv1, sv2);
3424 #ifdef USE_LOCALE_COLLATE
3426 * Any scalar variable may carry an 'o' magic that contains the
3427 * scalar data of the variable transformed to such a format that
3428 * a normal memory comparison can be used to compare the data
3429 * according to the locale settings.
3432 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3436 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3437 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3442 Safefree(mg->mg_ptr);
3444 if ((xf = mem_collxfrm(s, len, &xlen))) {
3445 if (SvREADONLY(sv)) {
3448 return xf + sizeof(PL_collation_ix);
3451 sv_magic(sv, 0, 'o', 0, 0);
3452 mg = mg_find(sv, 'o');
3465 if (mg && mg->mg_ptr) {
3467 return mg->mg_ptr + sizeof(PL_collation_ix);
3475 #endif /* USE_LOCALE_COLLATE */
3478 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3483 register STDCHAR rslast;
3484 register STDCHAR *bp;
3488 SV_CHECK_THINKFIRST(sv);
3489 (void)SvUPGRADE(sv, SVt_PV);
3493 if (RsSNARF(PL_rs)) {
3497 else if (RsRECORD(PL_rs)) {
3498 I32 recsize, bytesread;
3501 /* Grab the size of the record we're getting */
3502 recsize = SvIV(SvRV(PL_rs));
3503 (void)SvPOK_only(sv); /* Validate pointer */
3504 buffer = SvGROW(sv, recsize + 1);
3507 /* VMS wants read instead of fread, because fread doesn't respect */
3508 /* RMS record boundaries. This is not necessarily a good thing to be */
3509 /* doing, but we've got no other real choice */
3510 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3512 bytesread = PerlIO_read(fp, buffer, recsize);
3514 SvCUR_set(sv, bytesread);
3515 buffer[bytesread] = '\0';
3516 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3518 else if (RsPARA(PL_rs)) {
3523 rsptr = SvPV(PL_rs, rslen);
3524 rslast = rslen ? rsptr[rslen - 1] : '\0';
3526 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3527 do { /* to make sure file boundaries work right */
3530 i = PerlIO_getc(fp);
3534 PerlIO_ungetc(fp,i);
3540 /* See if we know enough about I/O mechanism to cheat it ! */
3542 /* This used to be #ifdef test - it is made run-time test for ease
3543 of abstracting out stdio interface. One call should be cheap
3544 enough here - and may even be a macro allowing compile
3548 if (PerlIO_fast_gets(fp)) {
3551 * We're going to steal some values from the stdio struct
3552 * and put EVERYTHING in the innermost loop into registers.
3554 register STDCHAR *ptr;
3558 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3559 /* An ungetc()d char is handled separately from the regular
3560 * buffer, so we getc() it back out and stuff it in the buffer.
3562 i = PerlIO_getc(fp);
3563 if (i == EOF) return 0;
3564 *(--((*fp)->_ptr)) = (unsigned char) i;
3568 /* Here is some breathtakingly efficient cheating */
3570 cnt = PerlIO_get_cnt(fp); /* get count into register */
3571 (void)SvPOK_only(sv); /* validate pointer */
3572 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3573 if (cnt > 80 && SvLEN(sv) > append) {
3574 shortbuffered = cnt - SvLEN(sv) + append + 1;
3575 cnt -= shortbuffered;
3579 /* remember that cnt can be negative */
3580 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3585 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3586 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3587 DEBUG_P(PerlIO_printf(Perl_debug_log,
3588 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3589 DEBUG_P(PerlIO_printf(Perl_debug_log,
3590 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3591 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3592 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3597 while (cnt > 0) { /* this | eat */
3599 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3600 goto thats_all_folks; /* screams | sed :-) */
3604 Copy(ptr, bp, cnt, char); /* this | eat */
3605 bp += cnt; /* screams | dust */
3606 ptr += cnt; /* louder | sed :-) */
3611 if (shortbuffered) { /* oh well, must extend */
3612 cnt = shortbuffered;
3614 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3616 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3617 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3621 DEBUG_P(PerlIO_printf(Perl_debug_log,
3622 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3623 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3624 DEBUG_P(PerlIO_printf(Perl_debug_log,
3625 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3626 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3627 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3628 /* This used to call 'filbuf' in stdio form, but as that behaves like
3629 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3630 another abstraction. */
3631 i = PerlIO_getc(fp); /* get more characters */
3632 DEBUG_P(PerlIO_printf(Perl_debug_log,
3633 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3634 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3635 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3636 cnt = PerlIO_get_cnt(fp);
3637 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3638 DEBUG_P(PerlIO_printf(Perl_debug_log,
3639 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3641 if (i == EOF) /* all done for ever? */
3642 goto thats_really_all_folks;
3644 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3646 SvGROW(sv, bpx + cnt + 2);
3647 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3649 *bp++ = i; /* store character from PerlIO_getc */
3651 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3652 goto thats_all_folks;
3656 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3657 memNE((char*)bp - rslen, rsptr, rslen))
3658 goto screamer; /* go back to the fray */
3659 thats_really_all_folks:
3661 cnt += shortbuffered;
3662 DEBUG_P(PerlIO_printf(Perl_debug_log,
3663 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3664 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3665 DEBUG_P(PerlIO_printf(Perl_debug_log,
3666 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3667 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3668 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3670 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3671 DEBUG_P(PerlIO_printf(Perl_debug_log,
3672 "Screamer: done, len=%ld, string=|%.*s|\n",
3673 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3678 /*The big, slow, and stupid way */
3681 /* Need to work around EPOC SDK features */
3682 /* On WINS: MS VC5 generates calls to _chkstk, */
3683 /* if a `large' stack frame is allocated */
3684 /* gcc on MARM does not generate calls like these */
3690 register STDCHAR *bpe = buf + sizeof(buf);
3692 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3693 ; /* keep reading */
3697 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3698 /* Accomodate broken VAXC compiler, which applies U8 cast to
3699 * both args of ?: operator, causing EOF to change into 255
3701 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3705 sv_catpvn(sv, (char *) buf, cnt);
3707 sv_setpvn(sv, (char *) buf, cnt);
3709 if (i != EOF && /* joy */
3711 SvCUR(sv) < rslen ||
3712 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3716 * If we're reading from a TTY and we get a short read,
3717 * indicating that the user hit his EOF character, we need
3718 * to notice it now, because if we try to read from the TTY
3719 * again, the EOF condition will disappear.
3721 * The comparison of cnt to sizeof(buf) is an optimization
3722 * that prevents unnecessary calls to feof().
3726 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3731 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3732 while (i != EOF) { /* to make sure file boundaries work right */
3733 i = PerlIO_getc(fp);
3735 PerlIO_ungetc(fp,i);
3742 win32_strip_return(sv);
3745 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3750 Perl_sv_inc(pTHX_ register SV *sv)
3759 if (SvTHINKFIRST(sv)) {
3760 if (SvREADONLY(sv)) {
3762 if (PL_curcop != &PL_compiling)
3763 Perl_croak(aTHX_ PL_no_modify);
3767 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3774 flags = SvFLAGS(sv);
3775 if (flags & SVp_NOK) {
3776 (void)SvNOK_only(sv);
3780 if (flags & SVp_IOK) {
3782 if (SvUVX(sv) == UV_MAX)
3783 sv_setnv(sv, (NV)UV_MAX + 1.0);
3785 (void)SvIOK_only_UV(sv);
3788 if (SvIVX(sv) == IV_MAX)
3789 sv_setnv(sv, (NV)IV_MAX + 1.0);
3791 (void)SvIOK_only(sv);
3797 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3798 if ((flags & SVTYPEMASK) < SVt_PVNV)
3799 sv_upgrade(sv, SVt_NV);
3801 (void)SvNOK_only(sv);
3805 while (isALPHA(*d)) d++;
3806 while (isDIGIT(*d)) d++;
3808 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
3812 while (d >= SvPVX(sv)) {
3820 /* MKS: The original code here died if letters weren't consecutive.
3821 * at least it didn't have to worry about non-C locales. The
3822 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3823 * arranged in order (although not consecutively) and that only
3824 * [A-Za-z] are accepted by isALPHA in the C locale.
3826 if (*d != 'z' && *d != 'Z') {
3827 do { ++*d; } while (!isALPHA(*d));
3830 *(d--) -= 'z' - 'a';
3835 *(d--) -= 'z' - 'a' + 1;
3839 /* oh,oh, the number grew */
3840 SvGROW(sv, SvCUR(sv) + 2);
3842 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3851 Perl_sv_dec(pTHX_ register SV *sv)
3859 if (SvTHINKFIRST(sv)) {
3860 if (SvREADONLY(sv)) {
3862 if (PL_curcop != &PL_compiling)
3863 Perl_croak(aTHX_ PL_no_modify);
3867 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3874 flags = SvFLAGS(sv);
3875 if (flags & SVp_NOK) {
3877 (void)SvNOK_only(sv);
3880 if (flags & SVp_IOK) {
3882 if (SvUVX(sv) == 0) {
3883 (void)SvIOK_only(sv);
3887 (void)SvIOK_only_UV(sv);
3891 if (SvIVX(sv) == IV_MIN)
3892 sv_setnv(sv, (NV)IV_MIN - 1.0);
3894 (void)SvIOK_only(sv);
3900 if (!(flags & SVp_POK)) {
3901 if ((flags & SVTYPEMASK) < SVt_PVNV)
3902 sv_upgrade(sv, SVt_NV);
3904 (void)SvNOK_only(sv);
3907 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
3910 /* Make a string that will exist for the duration of the expression
3911 * evaluation. Actually, it may have to last longer than that, but
3912 * hopefully we won't free it until it has been assigned to a
3913 * permanent location. */
3916 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3922 sv_setsv(sv,oldstr);
3924 PL_tmps_stack[++PL_tmps_ix] = sv;
3930 Perl_sv_newmortal(pTHX)
3936 SvFLAGS(sv) = SVs_TEMP;
3938 PL_tmps_stack[++PL_tmps_ix] = sv;
3942 /* same thing without the copying */
3945 Perl_sv_2mortal(pTHX_ register SV *sv)
3950 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3953 PL_tmps_stack[++PL_tmps_ix] = sv;
3959 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3966 sv_setpvn(sv,s,len);
3971 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3976 sv_setpvn(sv,s,len);
3980 #if defined(PERL_IMPLICIT_CONTEXT)
3982 Perl_newSVpvf_nocontext(const char* pat, ...)
3989 va_start(args, pat);
3990 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
3997 Perl_newSVpvf(pTHX_ const char* pat, ...)
4003 va_start(args, pat);
4004 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4010 Perl_newSVnv(pTHX_ NV n)
4020 Perl_newSViv(pTHX_ IV i)
4030 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4036 sv_upgrade(sv, SVt_RV);
4044 Perl_newRV(pTHX_ SV *tmpRef)
4046 return newRV_noinc(SvREFCNT_inc(tmpRef));
4049 /* make an exact duplicate of old */
4052 Perl_newSVsv(pTHX_ register SV *old)
4058 if (SvTYPE(old) == SVTYPEMASK) {
4059 Perl_warn(aTHX_ "semi-panic: attempt to dup freed string");
4074 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4087 if (!*s) { /* reset ?? searches */
4088 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4089 pm->op_pmdynflags &= ~PMdf_USED;
4094 /* reset variables */
4096 if (!HvARRAY(stash))
4099 Zero(todo, 256, char);
4106 for ( ; i <= max; i++) {
4109 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4110 for (entry = HvARRAY(stash)[i];
4112 entry = HeNEXT(entry))
4114 if (!todo[(U8)*HeKEY(entry)])
4116 gv = (GV*)HeVAL(entry);
4118 if (SvTHINKFIRST(sv)) {
4119 if (!SvREADONLY(sv) && SvROK(sv))
4124 if (SvTYPE(sv) >= SVt_PV) {
4126 if (SvPVX(sv) != Nullch)
4133 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4135 #ifndef VMS /* VMS has no environ array */
4137 environ[0] = Nullch;
4146 Perl_sv_2io(pTHX_ SV *sv)
4152 switch (SvTYPE(sv)) {
4160 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4164 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4166 return sv_2io(SvRV(sv));
4167 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4173 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4180 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4187 return *gvp = Nullgv, Nullcv;
4188 switch (SvTYPE(sv)) {
4208 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4209 tryAMAGICunDEREF(to_cv);
4212 if (SvTYPE(sv) == SVt_PVCV) {
4221 Perl_croak(aTHX_ "Not a subroutine reference");
4226 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4232 if (lref && !GvCVu(gv)) {
4235 tmpsv = NEWSV(704,0);
4236 gv_efullname3(tmpsv, gv, Nullch);
4237 /* XXX this is probably not what they think they're getting.
4238 * It has the same effect as "sub name;", i.e. just a forward
4240 newSUB(start_subparse(FALSE, 0),
4241 newSVOP(OP_CONST, 0, tmpsv),
4246 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4253 Perl_sv_true(pTHX_ register SV *sv)
4260 if ((tXpv = (XPV*)SvANY(sv)) &&
4261 (*tXpv->xpv_pv > '0' ||
4262 tXpv->xpv_cur > 1 ||
4263 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4270 return SvIVX(sv) != 0;
4273 return SvNVX(sv) != 0.0;
4275 return sv_2bool(sv);
4281 Perl_sv_iv(pTHX_ register SV *sv)
4285 return (IV)SvUVX(sv);
4292 Perl_sv_uv(pTHX_ register SV *sv)
4297 return (UV)SvIVX(sv);
4303 Perl_sv_nv(pTHX_ register SV *sv)
4311 Perl_sv_pv(pTHX_ SV *sv)
4318 return sv_2pv(sv, &n_a);
4322 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4328 return sv_2pv(sv, lp);
4332 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4336 if (SvTHINKFIRST(sv) && !SvROK(sv))
4337 sv_force_normal(sv);
4343 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4345 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4346 PL_op_name[PL_op->op_type]);
4350 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4355 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4356 SvGROW(sv, len + 1);
4357 Move(s,SvPVX(sv),len,char);
4362 SvPOK_on(sv); /* validate pointer */
4364 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4365 (unsigned long)sv,SvPVX(sv)));
4372 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4374 if (ob && SvOBJECT(sv))
4375 return HvNAME(SvSTASH(sv));
4377 switch (SvTYPE(sv)) {
4391 case SVt_PVLV: return "LVALUE";
4392 case SVt_PVAV: return "ARRAY";
4393 case SVt_PVHV: return "HASH";
4394 case SVt_PVCV: return "CODE";
4395 case SVt_PVGV: return "GLOB";
4396 case SVt_PVFM: return "FORMAT";
4397 default: return "UNKNOWN";
4403 Perl_sv_isobject(pTHX_ SV *sv)
4418 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4430 return strEQ(HvNAME(SvSTASH(sv)), name);
4434 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4441 SV_CHECK_THINKFIRST(rv);
4444 if (SvTYPE(rv) < SVt_RV)
4445 sv_upgrade(rv, SVt_RV);
4452 HV* stash = gv_stashpv(classname, TRUE);
4453 (void)sv_bless(rv, stash);
4459 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4462 sv_setsv(rv, &PL_sv_undef);
4466 sv_setiv(newSVrv(rv,classname), (IV)pv);
4471 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4473 sv_setiv(newSVrv(rv,classname), iv);
4478 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4480 sv_setnv(newSVrv(rv,classname), nv);
4485 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4487 sv_setpvn(newSVrv(rv,classname), pv, n);
4492 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4497 Perl_croak(aTHX_ "Can't bless non-reference value");
4499 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4500 if (SvREADONLY(tmpRef))
4501 Perl_croak(aTHX_ PL_no_modify);
4502 if (SvOBJECT(tmpRef)) {
4503 if (SvTYPE(tmpRef) != SVt_PVIO)
4505 SvREFCNT_dec(SvSTASH(tmpRef));
4508 SvOBJECT_on(tmpRef);
4509 if (SvTYPE(tmpRef) != SVt_PVIO)
4511 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4512 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4523 S_sv_unglob(pTHX_ SV *sv)
4525 assert(SvTYPE(sv) == SVt_PVGV);
4530 SvREFCNT_dec(GvSTASH(sv));
4531 GvSTASH(sv) = Nullhv;
4533 sv_unmagic(sv, '*');
4534 Safefree(GvNAME(sv));
4536 SvFLAGS(sv) &= ~SVTYPEMASK;
4537 SvFLAGS(sv) |= SVt_PVMG;
4541 Perl_sv_unref(pTHX_ SV *sv)
4545 if (SvWEAKREF(sv)) {
4553 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4556 sv_2mortal(rv); /* Schedule for freeing later */
4560 Perl_sv_taint(pTHX_ SV *sv)
4562 sv_magic((sv), Nullsv, 't', Nullch, 0);
4566 Perl_sv_untaint(pTHX_ SV *sv)
4568 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4569 MAGIC *mg = mg_find(sv, 't');
4576 Perl_sv_tainted(pTHX_ SV *sv)
4578 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4579 MAGIC *mg = mg_find(sv, 't');
4580 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4587 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4589 char buf[TYPE_CHARS(UV)];
4591 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4593 sv_setpvn(sv, ptr, ebuf - ptr);
4598 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4600 char buf[TYPE_CHARS(UV)];
4602 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4604 sv_setpvn(sv, ptr, ebuf - ptr);
4608 #if defined(PERL_IMPLICIT_CONTEXT)
4610 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4614 va_start(args, pat);
4615 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4621 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4625 va_start(args, pat);
4626 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4633 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4636 va_start(args, pat);
4637 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4643 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4646 va_start(args, pat);
4647 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4652 #if defined(PERL_IMPLICIT_CONTEXT)
4654 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4658 va_start(args, pat);
4659 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4664 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4668 va_start(args, pat);
4669 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4676 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4679 va_start(args, pat);
4680 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4685 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4688 va_start(args, pat);
4689 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4695 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4697 sv_setpvn(sv, "", 0);
4698 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4702 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4710 static char nullstr[] = "(null)";
4712 /* no matter what, this is a string now */
4713 (void)SvPV_force(sv, origlen);
4715 /* special-case "", "%s", and "%_" */
4718 if (patlen == 2 && pat[0] == '%') {
4722 char *s = va_arg(*args, char*);
4723 sv_catpv(sv, s ? s : nullstr);
4725 else if (svix < svmax)
4726 sv_catsv(sv, *svargs);
4730 sv_catsv(sv, va_arg(*args, SV*));
4733 /* See comment on '_' below */
4738 patend = (char*)pat + patlen;
4739 for (p = (char*)pat; p < patend; p = q) {
4747 bool has_precis = FALSE;
4752 STRLEN esignlen = 0;
4754 char *eptr = Nullch;
4756 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4767 for (q = p; q < patend && *q != '%'; ++q) ;
4769 sv_catpvn(sv, p, q - p);
4807 case '1': case '2': case '3':
4808 case '4': case '5': case '6':
4809 case '7': case '8': case '9':
4812 width = width * 10 + (*q++ - '0');
4817 i = va_arg(*args, int);
4819 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4821 width = (i < 0) ? -i : i;
4832 i = va_arg(*args, int);
4834 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4835 precis = (i < 0) ? 0 : i;
4841 precis = precis * 10 + (*q++ - '0');
4850 #if 0 /* when quads have better support within Perl */
4851 if (*(q + 1) == 'l') {
4878 uv = va_arg(*args, int);
4880 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4882 eptr = (char*)utf8buf;
4883 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4887 c = va_arg(*args, int);
4889 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4896 eptr = va_arg(*args, char*);
4898 elen = strlen(eptr);
4901 elen = sizeof nullstr - 1;
4904 else if (svix < svmax) {
4905 eptr = SvPVx(svargs[svix++], elen);
4907 if (has_precis && precis < elen) {
4909 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4912 if (width) { /* fudge width (can't fudge elen) */
4913 width += elen - sv_len_utf8(svargs[svix - 1]);
4921 * The "%_" hack might have to be changed someday,
4922 * if ISO or ANSI decide to use '_' for something.
4923 * So we keep it hidden from users' code.
4927 eptr = SvPVx(va_arg(*args, SV*), elen);
4930 if (has_precis && elen > precis)
4938 uv = (UV)va_arg(*args, void*);
4940 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4951 case 'h': iv = (short)va_arg(*args, int); break;
4952 default: iv = va_arg(*args, int); break;
4953 case 'l': iv = va_arg(*args, long); break;
4954 case 'V': iv = va_arg(*args, IV); break;
4958 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4960 case 'h': iv = (short)iv; break;
4961 default: iv = (int)iv; break;
4962 case 'l': iv = (long)iv; break;
4969 esignbuf[esignlen++] = plus;
4973 esignbuf[esignlen++] = '-';
5003 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5004 default: uv = va_arg(*args, unsigned); break;
5005 case 'l': uv = va_arg(*args, unsigned long); break;
5006 case 'V': uv = va_arg(*args, UV); break;
5010 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5012 case 'h': uv = (unsigned short)uv; break;
5013 default: uv = (unsigned)uv; break;
5014 case 'l': uv = (unsigned long)uv; break;
5020 eptr = ebuf + sizeof ebuf;
5026 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5032 esignbuf[esignlen++] = '0';
5033 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5039 *--eptr = '0' + dig;
5041 if (alt && *eptr != '0')
5047 *--eptr = '0' + dig;
5049 if (alt && *eptr != '0')
5052 default: /* it had better be ten or less */
5055 *--eptr = '0' + dig;
5056 } while (uv /= base);
5059 elen = (ebuf + sizeof ebuf) - eptr;
5062 zeros = precis - elen;
5063 else if (precis == 0 && elen == 1 && *eptr == '0')
5068 /* FLOATING POINT */
5071 c = 'f'; /* maybe %F isn't supported here */
5077 /* This is evil, but floating point is even more evil */
5080 nv = va_arg(*args, NV);
5082 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5085 if (c != 'e' && c != 'E') {
5087 (void)frexp(nv, &i);
5088 if (i == PERL_INT_MIN)
5089 Perl_die(aTHX_ "panic: frexp");
5091 need = BIT_DIGITS(i);
5093 need += has_precis ? precis : 6; /* known default */
5097 need += 20; /* fudge factor */
5098 if (PL_efloatsize < need) {
5099 Safefree(PL_efloatbuf);
5100 PL_efloatsize = need + 20; /* more fudge */
5101 New(906, PL_efloatbuf, PL_efloatsize, char);
5104 eptr = ebuf + sizeof ebuf;
5107 #ifdef USE_LONG_DOUBLE
5112 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5117 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5130 RESTORE_NUMERIC_STANDARD();
5131 (void)sprintf(PL_efloatbuf, eptr, nv);
5132 RESTORE_NUMERIC_LOCAL();
5135 eptr = PL_efloatbuf;
5136 elen = strlen(PL_efloatbuf);
5140 * User-defined locales may include arbitrary characters.
5141 * And, unfortunately, some system may alloc the "C" locale
5142 * to be overridden by a malicious user.
5145 *used_locale = TRUE;
5146 #endif /* LC_NUMERIC */
5153 i = SvCUR(sv) - origlen;
5156 case 'h': *(va_arg(*args, short*)) = i; break;
5157 default: *(va_arg(*args, int*)) = i; break;
5158 case 'l': *(va_arg(*args, long*)) = i; break;
5159 case 'V': *(va_arg(*args, IV*)) = i; break;
5162 else if (svix < svmax)
5163 sv_setuv(svargs[svix++], (UV)i);
5164 continue; /* not "break" */
5170 if (!args && ckWARN(WARN_PRINTF) &&
5171 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5172 SV *msg = sv_newmortal();
5173 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5174 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5176 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5179 sv_catpv(msg, "end of string");
5180 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5183 /* output mangled stuff ... */
5189 /* ... right here, because formatting flags should not apply */
5190 SvGROW(sv, SvCUR(sv) + elen + 1);
5192 memcpy(p, eptr, elen);
5195 SvCUR(sv) = p - SvPVX(sv);
5196 continue; /* not "break" */
5199 have = esignlen + zeros + elen;
5200 need = (have > width ? have : width);
5203 SvGROW(sv, SvCUR(sv) + need + 1);
5205 if (esignlen && fill == '0') {
5206 for (i = 0; i < esignlen; i++)
5210 memset(p, fill, gap);
5213 if (esignlen && fill != '0') {
5214 for (i = 0; i < esignlen; i++)
5218 for (i = zeros; i; i--)
5222 memcpy(p, eptr, elen);
5226 memset(p, ' ', gap);
5230 SvCUR(sv) = p - SvPVX(sv);