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 if (ckWARN_d(WARN_INTERNAL))
209 Perl_warner(aTHX_ WARN_INTERNAL,
210 "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
217 #else /* ! DEBUGGING */
219 #define del_SV(p) plant_SV(p)
221 #endif /* DEBUGGING */
224 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
229 Zero(sva, size, char);
231 /* The first SV in an arena isn't an SV. */
232 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
233 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
234 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
236 PL_sv_arenaroot = sva;
237 PL_sv_root = sva + 1;
239 svend = &sva[SvREFCNT(sva) - 1];
242 SvANY(sv) = (void *)(SV*)(sv + 1);
243 SvFLAGS(sv) = SVTYPEMASK;
247 SvFLAGS(sv) = SVTYPEMASK;
250 /* sv_mutex must be held while calling more_sv() */
257 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
258 PL_nice_chunk = Nullch;
261 char *chunk; /* must use New here to match call to */
262 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
263 sv_add_arena(chunk, 1008, 0);
270 S_visit(pTHX_ SVFUNC_t f)
276 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
277 svend = &sva[SvREFCNT(sva)];
278 for (sv = sva + 1; sv < svend; ++sv) {
279 if (SvTYPE(sv) != SVTYPEMASK)
288 S_do_report_used(pTHX_ SV *sv)
290 if (SvTYPE(sv) != SVTYPEMASK) {
291 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
292 PerlIO_printf(PerlIO_stderr(), "****\n");
298 Perl_sv_report_used(pTHX)
300 visit(FUNC_NAME_TO_PTR(S_do_report_used));
304 S_do_clean_objs(pTHX_ SV *sv)
308 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
309 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
315 /* XXX Might want to check arrays, etc. */
318 #ifndef DISABLE_DESTRUCTOR_KLUDGE
320 S_do_clean_named_objs(pTHX_ SV *sv)
322 if (SvTYPE(sv) == SVt_PVGV) {
323 if ( SvOBJECT(GvSV(sv)) ||
324 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
325 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
326 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
327 GvCV(sv) && SvOBJECT(GvCV(sv)) )
329 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
337 Perl_sv_clean_objs(pTHX)
339 PL_in_clean_objs = TRUE;
340 visit(FUNC_NAME_TO_PTR(S_do_clean_objs));
341 #ifndef DISABLE_DESTRUCTOR_KLUDGE
342 /* some barnacles may yet remain, clinging to typeglobs */
343 visit(FUNC_NAME_TO_PTR(S_do_clean_named_objs));
345 PL_in_clean_objs = FALSE;
349 S_do_clean_all(pTHX_ SV *sv)
351 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
352 SvFLAGS(sv) |= SVf_BREAK;
357 Perl_sv_clean_all(pTHX)
359 PL_in_clean_all = TRUE;
360 visit(FUNC_NAME_TO_PTR(S_do_clean_all));
361 PL_in_clean_all = FALSE;
365 Perl_sv_free_arenas(pTHX)
370 /* Free arenas here, but be careful about fake ones. (We assume
371 contiguity of the fake ones with the corresponding real ones.) */
373 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
374 svanext = (SV*) SvANY(sva);
375 while (svanext && SvFAKE(svanext))
376 svanext = (SV*) SvANY(svanext);
379 Safefree((void *)sva);
383 Safefree(PL_nice_chunk);
384 PL_nice_chunk = Nullch;
385 PL_nice_chunk_size = 0;
399 * See comment in more_xiv() -- RAM.
401 PL_xiv_root = *(IV**)xiv;
403 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
407 S_del_xiv(pTHX_ XPVIV *p)
409 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
411 *(IV**)xiv = PL_xiv_root;
422 New(705, ptr, 1008/sizeof(XPV), XPV);
423 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
424 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
427 xivend = &xiv[1008 / sizeof(IV) - 1];
428 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
430 while (xiv < xivend) {
431 *(IV**)xiv = (IV *)(xiv + 1);
445 PL_xnv_root = *(NV**)xnv;
447 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
451 S_del_xnv(pTHX_ XPVNV *p)
453 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
455 *(NV**)xnv = PL_xnv_root;
465 New(711, xnv, 1008/sizeof(NV), NV);
466 xnvend = &xnv[1008 / sizeof(NV) - 1];
467 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
469 while (xnv < xnvend) {
470 *(NV**)xnv = (NV*)(xnv + 1);
484 PL_xrv_root = (XRV*)xrv->xrv_rv;
490 S_del_xrv(pTHX_ XRV *p)
493 p->xrv_rv = (SV*)PL_xrv_root;
502 register XRV* xrvend;
503 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
505 xrvend = &xrv[1008 / sizeof(XRV) - 1];
506 while (xrv < xrvend) {
507 xrv->xrv_rv = (SV*)(xrv + 1);
521 PL_xpv_root = (XPV*)xpv->xpv_pv;
527 S_del_xpv(pTHX_ XPV *p)
530 p->xpv_pv = (char*)PL_xpv_root;
539 register XPV* xpvend;
540 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
542 xpvend = &xpv[1008 / sizeof(XPV) - 1];
543 while (xpv < xpvend) {
544 xpv->xpv_pv = (char*)(xpv + 1);
551 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
552 #define del_XIV(p) Safefree((char*)p)
554 #define new_XIV() (void*)new_xiv()
555 #define del_XIV(p) del_xiv((XPVIV*) p)
559 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
560 #define del_XNV(p) Safefree((char*)p)
562 #define new_XNV() (void*)new_xnv()
563 #define del_XNV(p) del_xnv((XPVNV*) p)
567 #define new_XRV() (void*)safemalloc(sizeof(XRV))
568 #define del_XRV(p) Safefree((char*)p)
570 #define new_XRV() (void*)new_xrv()
571 #define del_XRV(p) del_xrv((XRV*) p)
575 #define new_XPV() (void*)safemalloc(sizeof(XPV))
576 #define del_XPV(p) Safefree((char*)p)
578 #define new_XPV() (void*)new_xpv()
579 #define del_XPV(p) del_xpv((XPV *)p)
583 # define my_safemalloc(s) safemalloc(s)
584 # define my_safefree(s) safefree(s)
587 S_my_safemalloc(MEM_SIZE size)
590 New(717, p, size, char);
593 # define my_safefree(s) Safefree(s)
596 #define new_XPVIV() (void*)my_safemalloc(sizeof(XPVIV))
597 #define del_XPVIV(p) my_safefree((char*)p)
599 #define new_XPVNV() (void*)my_safemalloc(sizeof(XPVNV))
600 #define del_XPVNV(p) my_safefree((char*)p)
602 #define new_XPVMG() (void*)my_safemalloc(sizeof(XPVMG))
603 #define del_XPVMG(p) my_safefree((char*)p)
605 #define new_XPVLV() (void*)my_safemalloc(sizeof(XPVLV))
606 #define del_XPVLV(p) my_safefree((char*)p)
608 #define new_XPVAV() (void*)my_safemalloc(sizeof(XPVAV))
609 #define del_XPVAV(p) my_safefree((char*)p)
611 #define new_XPVHV() (void*)my_safemalloc(sizeof(XPVHV))
612 #define del_XPVHV(p) my_safefree((char*)p)
614 #define new_XPVCV() (void*)my_safemalloc(sizeof(XPVCV))
615 #define del_XPVCV(p) my_safefree((char*)p)
617 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
618 #define del_XPVGV(p) my_safefree((char*)p)
620 #define new_XPVBM() (void*)my_safemalloc(sizeof(XPVBM))
621 #define del_XPVBM(p) my_safefree((char*)p)
623 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
624 #define del_XPVFM(p) my_safefree((char*)p)
626 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
627 #define del_XPVIO(p) my_safefree((char*)p)
630 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
640 if (SvTYPE(sv) == mt)
646 switch (SvTYPE(sv)) {
667 else if (mt < SVt_PVIV)
684 pv = (char*)SvRV(sv);
688 nv = (NV)(unsigned long)pv;
704 else if (mt == SVt_NV)
715 del_XPVIV(SvANY(sv));
725 del_XPVNV(SvANY(sv));
735 del_XPVMG(SvANY(sv));
738 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
743 Perl_croak(aTHX_ "Can't upgrade to undef");
745 SvANY(sv) = new_XIV();
749 SvANY(sv) = new_XNV();
753 SvANY(sv) = new_XRV();
757 SvANY(sv) = new_XPV();
763 SvANY(sv) = new_XPVIV();
773 SvANY(sv) = new_XPVNV();
781 SvANY(sv) = new_XPVMG();
791 SvANY(sv) = new_XPVLV();
805 SvANY(sv) = new_XPVAV();
820 SvANY(sv) = new_XPVHV();
836 SvANY(sv) = new_XPVCV();
837 Zero(SvANY(sv), 1, XPVCV);
847 SvANY(sv) = new_XPVGV();
862 SvANY(sv) = new_XPVBM();
875 SvANY(sv) = new_XPVFM();
876 Zero(SvANY(sv), 1, XPVFM);
886 SvANY(sv) = new_XPVIO();
887 Zero(SvANY(sv), 1, XPVIO);
898 SvFLAGS(sv) &= ~SVTYPEMASK;
904 Perl_sv_backoff(pTHX_ register SV *sv)
909 SvLEN(sv) += SvIVX(sv);
910 SvPVX(sv) -= SvIVX(sv);
912 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
914 SvFLAGS(sv) &= ~SVf_OOK;
919 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
924 if (newlen >= 0x10000) {
925 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
928 #endif /* HAS_64K_LIMIT */
931 if (SvTYPE(sv) < SVt_PV) {
932 sv_upgrade(sv, SVt_PV);
935 else if (SvOOK(sv)) { /* pv is offset? */
938 if (newlen > SvLEN(sv))
939 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
941 if (newlen >= 0x10000)
947 if (newlen > SvLEN(sv)) { /* need more room? */
948 if (SvLEN(sv) && s) {
949 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
950 STRLEN l = malloced_size((void*)SvPVX(sv));
956 Renew(s,newlen,char);
959 New(703,s,newlen,char);
961 SvLEN_set(sv, newlen);
967 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
969 SV_CHECK_THINKFIRST(sv);
970 switch (SvTYPE(sv)) {
972 sv_upgrade(sv, SVt_IV);
975 sv_upgrade(sv, SVt_PVNV);
979 sv_upgrade(sv, SVt_PVIV);
990 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
991 PL_op_desc[PL_op->op_type]);
994 (void)SvIOK_only(sv); /* validate number */
1000 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1007 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1015 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1022 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1024 SV_CHECK_THINKFIRST(sv);
1025 switch (SvTYPE(sv)) {
1028 sv_upgrade(sv, SVt_NV);
1033 sv_upgrade(sv, SVt_PVNV);
1044 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1045 PL_op_name[PL_op->op_type]);
1049 (void)SvNOK_only(sv); /* validate number */
1054 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1061 S_not_a_number(pTHX_ SV *sv)
1067 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1068 /* each *s can expand to 4 chars + "...\0",
1069 i.e. need room for 8 chars */
1071 for (s = SvPVX(sv); *s && d < limit; s++) {
1073 if (ch & 128 && !isPRINT_LC(ch)) {
1082 else if (ch == '\r') {
1086 else if (ch == '\f') {
1090 else if (ch == '\\') {
1094 else if (isPRINT_LC(ch))
1109 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric in %s", tmpbuf,
1110 PL_op_name[PL_op->op_type]);
1112 Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf);
1115 /* the number can be converted to _integer_ with atol() */
1116 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1117 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1118 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1119 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1121 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1122 until proven guilty, assume that things are not that bad... */
1125 Perl_sv_2iv(pTHX_ register SV *sv)
1129 if (SvGMAGICAL(sv)) {
1134 return I_V(SvNVX(sv));
1136 if (SvPOKp(sv) && SvLEN(sv))
1139 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1141 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1142 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1147 if (SvTHINKFIRST(sv)) {
1150 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1151 return SvIV(tmpstr);
1152 return (IV)SvRV(sv);
1154 if (SvREADONLY(sv)) {
1156 return I_V(SvNVX(sv));
1158 if (SvPOKp(sv) && SvLEN(sv))
1162 if (ckWARN(WARN_UNINITIALIZED))
1163 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1170 return (IV)(SvUVX(sv));
1177 /* We can cache the IV/UV value even if it not good enough
1178 * to reconstruct NV, since the conversion to PV will prefer
1179 * NV over IV/UV. XXXX 64-bit?
1182 if (SvTYPE(sv) == SVt_NV)
1183 sv_upgrade(sv, SVt_PVNV);
1186 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1187 SvIVX(sv) = I_V(SvNVX(sv));
1189 SvUVX(sv) = U_V(SvNVX(sv));
1192 DEBUG_c(PerlIO_printf(Perl_debug_log,
1193 "0x%lx 2iv(%lu => %ld) (as unsigned)\n",
1195 (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv)));
1196 return (IV)SvUVX(sv);
1199 else if (SvPOKp(sv) && SvLEN(sv)) {
1200 I32 numtype = looks_like_number(sv);
1202 /* We want to avoid a possible problem when we cache an IV which
1203 may be later translated to an NV, and the resulting NV is not
1204 the translation of the initial data.
1206 This means that if we cache such an IV, we need to cache the
1207 NV as well. Moreover, we trade speed for space, and do not
1208 cache the NV if not needed.
1210 if (numtype & IS_NUMBER_NOT_IV) {
1211 /* May be not an integer. Need to cache NV if we cache IV
1212 * - otherwise future conversion to NV will be wrong. */
1215 d = Atof(SvPVX(sv));
1217 if (SvTYPE(sv) < SVt_PVNV)
1218 sv_upgrade(sv, SVt_PVNV);
1222 #if defined(USE_LONG_DOUBLE)
1223 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1224 (unsigned long)sv, SvNVX(sv)));
1226 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1227 (unsigned long)sv, SvNVX(sv)));
1229 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1230 SvIVX(sv) = I_V(SvNVX(sv));
1232 SvUVX(sv) = U_V(SvNVX(sv));
1238 /* The NV may be reconstructed from IV - safe to cache IV,
1239 which may be calculated by atol(). */
1240 if (SvTYPE(sv) == SVt_PV)
1241 sv_upgrade(sv, SVt_PVIV);
1243 SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */
1245 else { /* Not a number. Cache 0. */
1248 if (SvTYPE(sv) < SVt_PVIV)
1249 sv_upgrade(sv, SVt_PVIV);
1252 if (ckWARN(WARN_NUMERIC))
1258 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1259 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1260 if (SvTYPE(sv) < SVt_IV)
1261 /* Typically the caller expects that sv_any is not NULL now. */
1262 sv_upgrade(sv, SVt_IV);
1265 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1266 (unsigned long)sv,(long)SvIVX(sv)));
1267 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1271 Perl_sv_2uv(pTHX_ register SV *sv)
1275 if (SvGMAGICAL(sv)) {
1280 return U_V(SvNVX(sv));
1281 if (SvPOKp(sv) && SvLEN(sv))
1284 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1286 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1287 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1292 if (SvTHINKFIRST(sv)) {
1295 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1296 return SvUV(tmpstr);
1297 return (UV)SvRV(sv);
1299 if (SvREADONLY(sv)) {
1301 return U_V(SvNVX(sv));
1303 if (SvPOKp(sv) && SvLEN(sv))
1307 if (ckWARN(WARN_UNINITIALIZED))
1308 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1318 return (UV)SvIVX(sv);
1322 /* We can cache the IV/UV value even if it not good enough
1323 * to reconstruct NV, since the conversion to PV will prefer
1324 * NV over IV/UV. XXXX 64-bit?
1326 if (SvTYPE(sv) == SVt_NV)
1327 sv_upgrade(sv, SVt_PVNV);
1329 if (SvNVX(sv) >= -0.5) {
1331 SvUVX(sv) = U_V(SvNVX(sv));
1334 SvIVX(sv) = I_V(SvNVX(sv));
1336 DEBUG_c(PerlIO_printf(Perl_debug_log,
1337 "0x%lx 2uv(%ld => %lu) (as signed)\n",
1338 (unsigned long)sv,(long)SvIVX(sv),
1339 (long)(UV)SvIVX(sv)));
1340 return (UV)SvIVX(sv);
1343 else if (SvPOKp(sv) && SvLEN(sv)) {
1344 I32 numtype = looks_like_number(sv);
1346 /* We want to avoid a possible problem when we cache a UV which
1347 may be later translated to an NV, and the resulting NV is not
1348 the translation of the initial data.
1350 This means that if we cache such a UV, we need to cache the
1351 NV as well. Moreover, we trade speed for space, and do not
1352 cache the NV if not needed.
1354 if (numtype & IS_NUMBER_NOT_IV) {
1355 /* May be not an integer. Need to cache NV if we cache IV
1356 * - otherwise future conversion to NV will be wrong. */
1359 d = Atof(SvPVX(sv)); /* XXXX 64-bit? */
1361 if (SvTYPE(sv) < SVt_PVNV)
1362 sv_upgrade(sv, SVt_PVNV);
1366 #if defined(USE_LONG_DOUBLE)
1367 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1368 (unsigned long)sv, SvNVX(sv)));
1370 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1371 (unsigned long)sv, SvNVX(sv)));
1373 if (SvNVX(sv) < -0.5) {
1374 SvIVX(sv) = I_V(SvNVX(sv));
1377 SvUVX(sv) = U_V(SvNVX(sv));
1381 else if (numtype & IS_NUMBER_NEG) {
1382 /* The NV may be reconstructed from IV - safe to cache IV,
1383 which may be calculated by atol(). */
1384 if (SvTYPE(sv) == SVt_PV)
1385 sv_upgrade(sv, SVt_PVIV);
1387 SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1389 else if (numtype) { /* Non-negative */
1390 /* The NV may be reconstructed from UV - safe to cache UV,
1391 which may be calculated by strtoul()/atol. */
1392 if (SvTYPE(sv) == SVt_PV)
1393 sv_upgrade(sv, SVt_PVIV);
1395 (void)SvIsUV_on(sv);
1397 SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */
1398 #else /* no atou(), but we know the number fits into IV... */
1399 /* The only problem may be if it is negative... */
1400 SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */
1403 else { /* Not a number. Cache 0. */
1406 if (SvTYPE(sv) < SVt_PVIV)
1407 sv_upgrade(sv, SVt_PVIV);
1408 SvUVX(sv) = 0; /* We assume that 0s have the
1409 same bitmap in IV and UV. */
1411 (void)SvIsUV_on(sv);
1412 if (ckWARN(WARN_NUMERIC))
1417 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1419 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1420 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1422 if (SvTYPE(sv) < SVt_IV)
1423 /* Typically the caller expects that sv_any is not NULL now. */
1424 sv_upgrade(sv, SVt_IV);
1428 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1429 (unsigned long)sv,SvUVX(sv)));
1430 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1434 Perl_sv_2nv(pTHX_ register SV *sv)
1438 if (SvGMAGICAL(sv)) {
1442 if (SvPOKp(sv) && SvLEN(sv)) {
1444 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1446 return Atof(SvPVX(sv));
1450 return (NV)SvUVX(sv);
1452 return (NV)SvIVX(sv);
1455 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1457 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1458 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1463 if (SvTHINKFIRST(sv)) {
1466 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1467 return SvNV(tmpstr);
1468 return (NV)(unsigned long)SvRV(sv);
1470 if (SvREADONLY(sv)) {
1472 if (SvPOKp(sv) && SvLEN(sv)) {
1473 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1475 return Atof(SvPVX(sv));
1479 return (NV)SvUVX(sv);
1481 return (NV)SvIVX(sv);
1483 if (ckWARN(WARN_UNINITIALIZED))
1484 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1488 if (SvTYPE(sv) < SVt_NV) {
1489 if (SvTYPE(sv) == SVt_IV)
1490 sv_upgrade(sv, SVt_PVNV);
1492 sv_upgrade(sv, SVt_NV);
1493 #if defined(USE_LONG_DOUBLE)
1495 RESTORE_NUMERIC_STANDARD();
1496 PerlIO_printf(Perl_debug_log, "0x%lx num(%Lg)\n",
1497 (unsigned long)sv, SvNVX(sv));
1498 RESTORE_NUMERIC_LOCAL();
1502 RESTORE_NUMERIC_STANDARD();
1503 PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
1504 (unsigned long)sv, SvNVX(sv));
1505 RESTORE_NUMERIC_LOCAL();
1509 else if (SvTYPE(sv) < SVt_PVNV)
1510 sv_upgrade(sv, SVt_PVNV);
1512 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1514 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1516 else if (SvPOKp(sv) && SvLEN(sv)) {
1518 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1520 SvNVX(sv) = Atof(SvPVX(sv));
1524 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1525 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1526 if (SvTYPE(sv) < SVt_NV)
1527 /* Typically the caller expects that sv_any is not NULL now. */
1528 sv_upgrade(sv, SVt_NV);
1532 #if defined(USE_LONG_DOUBLE)
1534 RESTORE_NUMERIC_STANDARD();
1535 PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n",
1536 (unsigned long)sv, SvNVX(sv));
1537 RESTORE_NUMERIC_LOCAL();
1541 RESTORE_NUMERIC_STANDARD();
1542 PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
1543 (unsigned long)sv, SvNVX(sv));
1544 RESTORE_NUMERIC_LOCAL();
1551 S_asIV(pTHX_ SV *sv)
1553 I32 numtype = looks_like_number(sv);
1556 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1557 return atol(SvPVX(sv)); /* XXXX 64-bit? */
1560 if (ckWARN(WARN_NUMERIC))
1563 d = Atof(SvPVX(sv));
1568 S_asUV(pTHX_ SV *sv)
1570 I32 numtype = looks_like_number(sv);
1573 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1574 return strtoul(SvPVX(sv), Null(char**), 10);
1578 if (ckWARN(WARN_NUMERIC))
1581 return U_V(Atof(SvPVX(sv)));
1585 * Returns a combination of (advisory only - can get false negatives)
1586 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1588 * 0 if does not look like number.
1590 * In fact possible values are 0 and
1591 * IS_NUMBER_TO_INT_BY_ATOL 123
1592 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1593 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1594 * with a possible addition of IS_NUMBER_NEG.
1598 Perl_looks_like_number(pTHX_ SV *sv)
1600 /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but
1601 * using atof() may lose precision. */
1603 register char *send;
1604 register char *sbegin;
1605 register char *nbegin;
1613 else if (SvPOKp(sv))
1614 sbegin = SvPV(sv, len);
1617 send = sbegin + len;
1624 numtype = IS_NUMBER_NEG;
1631 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1632 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1636 /* next must be digit or the radix separator */
1640 } while (isDIGIT(*s));
1642 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1643 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1645 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1648 #ifdef USE_LOCALE_NUMERIC
1649 || IS_NUMERIC_RADIX(*s)
1653 numtype |= IS_NUMBER_NOT_IV;
1654 while (isDIGIT(*s)) /* optional digits after the radix */
1659 #ifdef USE_LOCALE_NUMERIC
1660 || IS_NUMERIC_RADIX(*s)
1664 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1665 /* no digits before the radix means we need digits after it */
1669 } while (isDIGIT(*s));
1677 /* we can have an optional exponent part */
1678 if (*s == 'e' || *s == 'E') {
1679 numtype &= ~IS_NUMBER_NEG;
1680 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1682 if (*s == '+' || *s == '-')
1687 } while (isDIGIT(*s));
1696 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1697 return IS_NUMBER_TO_INT_BY_ATOL;
1702 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1705 return sv_2pv(sv, &n_a);
1708 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1710 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1713 char *ptr = buf + TYPE_CHARS(UV);
1728 *--ptr = '0' + (uv % 10);
1737 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
1742 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
1743 char *tmpbuf = tbuf;
1749 if (SvGMAGICAL(sv)) {
1755 if (SvIOKp(sv)) { /* XXXX 64-bit? */
1757 (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv));
1759 (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv));
1764 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1769 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1771 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1772 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1778 if (SvTHINKFIRST(sv)) {
1781 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
1782 return SvPV(tmpstr,*lp);
1789 switch (SvTYPE(sv)) {
1791 if ( ((SvFLAGS(sv) &
1792 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
1793 == (SVs_OBJECT|SVs_RMG))
1794 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
1795 && (mg = mg_find(sv, 'r'))) {
1797 regexp *re = (regexp *)mg->mg_obj;
1800 char *fptr = "msix";
1805 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
1807 while(ch = *fptr++) {
1809 reflags[left++] = ch;
1812 reflags[right--] = ch;
1817 reflags[left] = '-';
1821 mg->mg_len = re->prelen + 4 + left;
1822 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
1823 Copy("(?", mg->mg_ptr, 2, char);
1824 Copy(reflags, mg->mg_ptr+2, left, char);
1825 Copy(":", mg->mg_ptr+left+2, 1, char);
1826 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
1827 mg->mg_ptr[mg->mg_len - 1] = ')';
1828 mg->mg_ptr[mg->mg_len] = 0;
1830 PL_reginterp_cnt += re->program[0].next_off;
1842 case SVt_PVBM: s = "SCALAR"; break;
1843 case SVt_PVLV: s = "LVALUE"; break;
1844 case SVt_PVAV: s = "ARRAY"; break;
1845 case SVt_PVHV: s = "HASH"; break;
1846 case SVt_PVCV: s = "CODE"; break;
1847 case SVt_PVGV: s = "GLOB"; break;
1848 case SVt_PVFM: s = "FORMAT"; break;
1849 case SVt_PVIO: s = "IO"; break;
1850 default: s = "UNKNOWN"; break;
1854 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
1858 Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv);
1864 if (SvREADONLY(sv)) {
1865 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1866 /* XXXX 64-bit? IV may have better precision... */
1867 Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf);
1875 tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf);
1877 tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf);
1884 if (ckWARN(WARN_UNINITIALIZED))
1885 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1891 if (SvNOKp(sv)) { /* See note in sv_2uv() */
1892 /* XXXX 64-bit? IV may have better precision... */
1893 if (SvTYPE(sv) < SVt_PVNV)
1894 sv_upgrade(sv, SVt_PVNV);
1897 olderrno = errno; /* some Xenix systems wipe out errno here */
1899 if (SvNVX(sv) == 0.0)
1900 (void)strcpy(s,"0");
1904 Gconvert(SvNVX(sv), DBL_DIG, 0, s);
1907 #ifdef FIXNEGATIVEZERO
1908 if (*s == '-' && s[1] == '0' && !s[2])
1917 else if (SvIOKp(sv)) {
1918 U32 isIOK = SvIOK(sv);
1919 char buf[TYPE_CHARS(UV)];
1922 if (SvTYPE(sv) < SVt_PVIV)
1923 sv_upgrade(sv, SVt_PVIV);
1925 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
1926 sv_setpvn(sv, ptr, ebuf - ptr);
1930 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
1931 sv_setpvn(sv, ptr, ebuf - ptr);
1941 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1942 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1944 if (SvTYPE(sv) < SVt_PV)
1945 /* Typically the caller expects that sv_any is not NULL now. */
1946 sv_upgrade(sv, SVt_PV);
1949 *lp = s - SvPVX(sv);
1952 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv)));
1956 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
1957 /* Sneaky stuff here */
1961 tsv = newSVpv(tmpbuf, 0);
1977 len = strlen(tmpbuf);
1979 #ifdef FIXNEGATIVEZERO
1980 if (len == 2 && t[0] == '-' && t[1] == '0') {
1985 (void)SvUPGRADE(sv, SVt_PV);
1987 s = SvGROW(sv, len + 1);
1995 /* This function is only called on magical items */
1997 Perl_sv_2bool(pTHX_ register SV *sv)
2007 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2008 return SvTRUE(tmpsv);
2009 return SvRV(sv) != 0;
2012 register XPV* Xpvtmp;
2013 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2014 (*Xpvtmp->xpv_pv > '0' ||
2015 Xpvtmp->xpv_cur > 1 ||
2016 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2023 return SvIVX(sv) != 0;
2026 return SvNVX(sv) != 0.0;
2033 /* Note: sv_setsv() should not be called with a source string that needs
2034 * to be reused, since it may destroy the source string if it is marked
2039 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2042 register U32 sflags;
2048 SV_CHECK_THINKFIRST(dstr);
2050 sstr = &PL_sv_undef;
2051 stype = SvTYPE(sstr);
2052 dtype = SvTYPE(dstr);
2056 /* There's a lot of redundancy below but we're going for speed here */
2061 if (dtype != SVt_PVGV) {
2062 (void)SvOK_off(dstr);
2070 sv_upgrade(dstr, SVt_IV);
2073 sv_upgrade(dstr, SVt_PVNV);
2077 sv_upgrade(dstr, SVt_PVIV);
2080 (void)SvIOK_only(dstr);
2081 SvIVX(dstr) = SvIVX(sstr);
2094 sv_upgrade(dstr, SVt_NV);
2099 sv_upgrade(dstr, SVt_PVNV);
2102 SvNVX(dstr) = SvNVX(sstr);
2103 (void)SvNOK_only(dstr);
2111 sv_upgrade(dstr, SVt_RV);
2112 else if (dtype == SVt_PVGV &&
2113 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2116 if (PL_curcop->cop_stash != GvSTASH(dstr))
2117 GvIMPORTED_on(dstr);
2127 sv_upgrade(dstr, SVt_PV);
2130 if (dtype < SVt_PVIV)
2131 sv_upgrade(dstr, SVt_PVIV);
2134 if (dtype < SVt_PVNV)
2135 sv_upgrade(dstr, SVt_PVNV);
2142 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2143 PL_op_name[PL_op->op_type]);
2145 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2149 if (dtype <= SVt_PVGV) {
2151 if (dtype != SVt_PVGV) {
2152 char *name = GvNAME(sstr);
2153 STRLEN len = GvNAMELEN(sstr);
2154 sv_upgrade(dstr, SVt_PVGV);
2155 sv_magic(dstr, dstr, '*', name, len);
2156 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2157 GvNAME(dstr) = savepvn(name, len);
2158 GvNAMELEN(dstr) = len;
2159 SvFAKE_on(dstr); /* can coerce to non-glob */
2161 /* ahem, death to those who redefine active sort subs */
2162 else if (PL_curstackinfo->si_type == PERLSI_SORT
2163 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2164 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2166 (void)SvOK_off(dstr);
2167 GvINTRO_off(dstr); /* one-shot flag */
2169 GvGP(dstr) = gp_ref(GvGP(sstr));
2171 if (PL_curcop->cop_stash != GvSTASH(dstr))
2172 GvIMPORTED_on(dstr);
2179 if (SvGMAGICAL(sstr)) {
2181 if (SvTYPE(sstr) != stype) {
2182 stype = SvTYPE(sstr);
2183 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2187 if (stype == SVt_PVLV)
2188 (void)SvUPGRADE(dstr, SVt_PVNV);
2190 (void)SvUPGRADE(dstr, stype);
2193 sflags = SvFLAGS(sstr);
2195 if (sflags & SVf_ROK) {
2196 if (dtype >= SVt_PV) {
2197 if (dtype == SVt_PVGV) {
2198 SV *sref = SvREFCNT_inc(SvRV(sstr));
2200 int intro = GvINTRO(dstr);
2204 GvGP(dstr)->gp_refcnt--;
2205 GvINTRO_off(dstr); /* one-shot flag */
2206 Newz(602,gp, 1, GP);
2207 GvGP(dstr) = gp_ref(gp);
2208 GvSV(dstr) = NEWSV(72,0);
2209 GvLINE(dstr) = PL_curcop->cop_line;
2210 GvEGV(dstr) = (GV*)dstr;
2213 switch (SvTYPE(sref)) {
2216 SAVESPTR(GvAV(dstr));
2218 dref = (SV*)GvAV(dstr);
2219 GvAV(dstr) = (AV*)sref;
2220 if (PL_curcop->cop_stash != GvSTASH(dstr))
2221 GvIMPORTED_AV_on(dstr);
2225 SAVESPTR(GvHV(dstr));
2227 dref = (SV*)GvHV(dstr);
2228 GvHV(dstr) = (HV*)sref;
2229 if (PL_curcop->cop_stash != GvSTASH(dstr))
2230 GvIMPORTED_HV_on(dstr);
2234 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2235 SvREFCNT_dec(GvCV(dstr));
2236 GvCV(dstr) = Nullcv;
2237 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2238 PL_sub_generation++;
2240 SAVESPTR(GvCV(dstr));
2243 dref = (SV*)GvCV(dstr);
2244 if (GvCV(dstr) != (CV*)sref) {
2245 CV* cv = GvCV(dstr);
2247 if (!GvCVGEN((GV*)dstr) &&
2248 (CvROOT(cv) || CvXSUB(cv)))
2250 SV *const_sv = cv_const_sv(cv);
2251 bool const_changed = TRUE;
2253 const_changed = sv_cmp(const_sv,
2254 op_const_sv(CvSTART((CV*)sref),
2256 /* ahem, death to those who redefine
2257 * active sort subs */
2258 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2259 PL_sortcop == CvSTART(cv))
2261 "Can't redefine active sort subroutine %s",
2262 GvENAME((GV*)dstr));
2263 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2264 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2265 && HvNAME(GvSTASH(CvGV(cv)))
2266 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2268 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2269 "Constant subroutine %s redefined"
2270 : "Subroutine %s redefined",
2271 GvENAME((GV*)dstr));
2274 cv_ckproto(cv, (GV*)dstr,
2275 SvPOK(sref) ? SvPVX(sref) : Nullch);
2277 GvCV(dstr) = (CV*)sref;
2278 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2279 GvASSUMECV_on(dstr);
2280 PL_sub_generation++;
2282 if (PL_curcop->cop_stash != GvSTASH(dstr))
2283 GvIMPORTED_CV_on(dstr);
2287 SAVESPTR(GvIOp(dstr));
2289 dref = (SV*)GvIOp(dstr);
2290 GvIOp(dstr) = (IO*)sref;
2294 SAVESPTR(GvSV(dstr));
2296 dref = (SV*)GvSV(dstr);
2298 if (PL_curcop->cop_stash != GvSTASH(dstr))
2299 GvIMPORTED_SV_on(dstr);
2310 (void)SvOOK_off(dstr); /* backoff */
2312 Safefree(SvPVX(dstr));
2313 SvLEN(dstr)=SvCUR(dstr)=0;
2316 (void)SvOK_off(dstr);
2317 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2319 if (sflags & SVp_NOK) {
2321 SvNVX(dstr) = SvNVX(sstr);
2323 if (sflags & SVp_IOK) {
2324 (void)SvIOK_on(dstr);
2325 SvIVX(dstr) = SvIVX(sstr);
2329 if (SvAMAGIC(sstr)) {
2333 else if (sflags & SVp_POK) {
2336 * Check to see if we can just swipe the string. If so, it's a
2337 * possible small lose on short strings, but a big win on long ones.
2338 * It might even be a win on short strings if SvPVX(dstr)
2339 * has to be allocated and SvPVX(sstr) has to be freed.
2342 if (SvTEMP(sstr) && /* slated for free anyway? */
2343 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2344 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2346 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2348 SvFLAGS(dstr) &= ~SVf_OOK;
2349 Safefree(SvPVX(dstr) - SvIVX(dstr));
2351 else if (SvLEN(dstr))
2352 Safefree(SvPVX(dstr));
2354 (void)SvPOK_only(dstr);
2355 SvPV_set(dstr, SvPVX(sstr));
2356 SvLEN_set(dstr, SvLEN(sstr));
2357 SvCUR_set(dstr, SvCUR(sstr));
2359 (void)SvOK_off(sstr);
2360 SvPV_set(sstr, Nullch);
2365 else { /* have to copy actual string */
2366 STRLEN len = SvCUR(sstr);
2368 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2369 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2370 SvCUR_set(dstr, len);
2371 *SvEND(dstr) = '\0';
2372 (void)SvPOK_only(dstr);
2375 if (sflags & SVp_NOK) {
2377 SvNVX(dstr) = SvNVX(sstr);
2379 if (sflags & SVp_IOK) {
2380 (void)SvIOK_on(dstr);
2381 SvIVX(dstr) = SvIVX(sstr);
2386 else if (sflags & SVp_NOK) {
2387 SvNVX(dstr) = SvNVX(sstr);
2388 (void)SvNOK_only(dstr);
2390 (void)SvIOK_on(dstr);
2391 SvIVX(dstr) = SvIVX(sstr);
2392 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2397 else if (sflags & SVp_IOK) {
2398 (void)SvIOK_only(dstr);
2399 SvIVX(dstr) = SvIVX(sstr);
2404 if (dtype == SVt_PVGV) {
2405 if (ckWARN(WARN_UNSAFE))
2406 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2409 (void)SvOK_off(dstr);
2415 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2417 sv_setsv(dstr,sstr);
2422 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2424 register char *dptr;
2425 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2426 elicit a warning, but it won't hurt. */
2427 SV_CHECK_THINKFIRST(sv);
2432 (void)SvUPGRADE(sv, SVt_PV);
2434 SvGROW(sv, len + 1);
2436 Move(ptr,dptr,len,char);
2439 (void)SvPOK_only(sv); /* validate pointer */
2444 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2446 sv_setpvn(sv,ptr,len);
2451 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2453 register STRLEN len;
2455 SV_CHECK_THINKFIRST(sv);
2461 (void)SvUPGRADE(sv, SVt_PV);
2463 SvGROW(sv, len + 1);
2464 Move(ptr,SvPVX(sv),len+1,char);
2466 (void)SvPOK_only(sv); /* validate pointer */
2471 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2478 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2480 SV_CHECK_THINKFIRST(sv);
2481 (void)SvUPGRADE(sv, SVt_PV);
2486 (void)SvOOK_off(sv);
2487 if (SvPVX(sv) && SvLEN(sv))
2488 Safefree(SvPVX(sv));
2489 Renew(ptr, len+1, char);
2492 SvLEN_set(sv, len+1);
2494 (void)SvPOK_only(sv); /* validate pointer */
2499 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2501 sv_usepvn(sv,ptr,len);
2506 Perl_sv_force_normal(pTHX_ register SV *sv)
2508 if (SvREADONLY(sv)) {
2510 if (PL_curcop != &PL_compiling)
2511 Perl_croak(aTHX_ PL_no_modify);
2515 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2520 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2524 register STRLEN delta;
2526 if (!ptr || !SvPOKp(sv))
2528 SV_CHECK_THINKFIRST(sv);
2529 if (SvTYPE(sv) < SVt_PVIV)
2530 sv_upgrade(sv,SVt_PVIV);
2533 if (!SvLEN(sv)) { /* make copy of shared string */
2534 char *pvx = SvPVX(sv);
2535 STRLEN len = SvCUR(sv);
2536 SvGROW(sv, len + 1);
2537 Move(pvx,SvPVX(sv),len,char);
2541 SvFLAGS(sv) |= SVf_OOK;
2543 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2544 delta = ptr - SvPVX(sv);
2552 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2557 junk = SvPV_force(sv, tlen);
2558 SvGROW(sv, tlen + len + 1);
2561 Move(ptr,SvPVX(sv)+tlen,len,char);
2564 (void)SvPOK_only(sv); /* validate pointer */
2569 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2571 sv_catpvn(sv,ptr,len);
2576 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2582 if (s = SvPV(sstr, len))
2583 sv_catpvn(dstr,s,len);
2587 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2589 sv_catsv(dstr,sstr);
2594 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2596 register STRLEN len;
2602 junk = SvPV_force(sv, tlen);
2604 SvGROW(sv, tlen + len + 1);
2607 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2609 (void)SvPOK_only(sv); /* validate pointer */
2614 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2621 Perl_newSV(pTHX_ STRLEN len)
2627 sv_upgrade(sv, SVt_PV);
2628 SvGROW(sv, len + 1);
2633 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2636 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2640 if (SvREADONLY(sv)) {
2642 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2643 Perl_croak(aTHX_ PL_no_modify);
2645 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2646 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2653 (void)SvUPGRADE(sv, SVt_PVMG);
2655 Newz(702,mg, 1, MAGIC);
2656 mg->mg_moremagic = SvMAGIC(sv);
2659 if (!obj || obj == sv || how == '#' || how == 'r')
2663 mg->mg_obj = SvREFCNT_inc(obj);
2664 mg->mg_flags |= MGf_REFCOUNTED;
2667 mg->mg_len = namlen;
2670 mg->mg_ptr = savepvn(name, namlen);
2671 else if (namlen == HEf_SVKEY)
2672 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2676 mg->mg_virtual = &PL_vtbl_sv;
2679 mg->mg_virtual = &PL_vtbl_amagic;
2682 mg->mg_virtual = &PL_vtbl_amagicelem;
2688 mg->mg_virtual = &PL_vtbl_bm;
2691 mg->mg_virtual = &PL_vtbl_regdata;
2694 mg->mg_virtual = &PL_vtbl_regdatum;
2697 mg->mg_virtual = &PL_vtbl_env;
2700 mg->mg_virtual = &PL_vtbl_fm;
2703 mg->mg_virtual = &PL_vtbl_envelem;
2706 mg->mg_virtual = &PL_vtbl_mglob;
2709 mg->mg_virtual = &PL_vtbl_isa;
2712 mg->mg_virtual = &PL_vtbl_isaelem;
2715 mg->mg_virtual = &PL_vtbl_nkeys;
2722 mg->mg_virtual = &PL_vtbl_dbline;
2726 mg->mg_virtual = &PL_vtbl_mutex;
2728 #endif /* USE_THREADS */
2729 #ifdef USE_LOCALE_COLLATE
2731 mg->mg_virtual = &PL_vtbl_collxfrm;
2733 #endif /* USE_LOCALE_COLLATE */
2735 mg->mg_virtual = &PL_vtbl_pack;
2739 mg->mg_virtual = &PL_vtbl_packelem;
2742 mg->mg_virtual = &PL_vtbl_regexp;
2745 mg->mg_virtual = &PL_vtbl_sig;
2748 mg->mg_virtual = &PL_vtbl_sigelem;
2751 mg->mg_virtual = &PL_vtbl_taint;
2755 mg->mg_virtual = &PL_vtbl_uvar;
2758 mg->mg_virtual = &PL_vtbl_vec;
2761 mg->mg_virtual = &PL_vtbl_substr;
2764 mg->mg_virtual = &PL_vtbl_defelem;
2767 mg->mg_virtual = &PL_vtbl_glob;
2770 mg->mg_virtual = &PL_vtbl_arylen;
2773 mg->mg_virtual = &PL_vtbl_pos;
2776 mg->mg_virtual = &PL_vtbl_backref;
2778 case '~': /* Reserved for use by extensions not perl internals. */
2779 /* Useful for attaching extension internal data to perl vars. */
2780 /* Note that multiple extensions may clash if magical scalars */
2781 /* etc holding private data from one are passed to another. */
2785 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
2789 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
2793 Perl_sv_unmagic(pTHX_ SV *sv, int type)
2797 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
2800 for (mg = *mgp; mg; mg = *mgp) {
2801 if (mg->mg_type == type) {
2802 MGVTBL* vtbl = mg->mg_virtual;
2803 *mgp = mg->mg_moremagic;
2804 if (vtbl && (vtbl->svt_free != NULL))
2805 (VTBL->svt_free)(aTHX_ sv, mg);
2806 if (mg->mg_ptr && mg->mg_type != 'g')
2807 if (mg->mg_len >= 0)
2808 Safefree(mg->mg_ptr);
2809 else if (mg->mg_len == HEf_SVKEY)
2810 SvREFCNT_dec((SV*)mg->mg_ptr);
2811 if (mg->mg_flags & MGf_REFCOUNTED)
2812 SvREFCNT_dec(mg->mg_obj);
2816 mgp = &mg->mg_moremagic;
2820 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
2827 Perl_sv_rvweaken(pTHX_ SV *sv)
2830 if (!SvOK(sv)) /* let undefs pass */
2833 Perl_croak(aTHX_ "Can't weaken a nonreference");
2834 else if (SvWEAKREF(sv)) {
2836 if (ckWARN(WARN_MISC))
2837 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
2841 sv_add_backref(tsv, sv);
2848 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
2852 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
2853 av = (AV*)mg->mg_obj;
2856 sv_magic(tsv, (SV*)av, '<', NULL, 0);
2857 SvREFCNT_dec(av); /* for sv_magic */
2863 S_sv_del_backref(pTHX_ SV *sv)
2870 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
2871 Perl_croak(aTHX_ "panic: del_backref");
2872 av = (AV *)mg->mg_obj;
2877 svp[i] = &PL_sv_undef; /* XXX */
2884 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
2888 register char *midend;
2889 register char *bigend;
2895 Perl_croak(aTHX_ "Can't modify non-existent substring");
2896 SvPV_force(bigstr, curlen);
2897 if (offset + len > curlen) {
2898 SvGROW(bigstr, offset+len+1);
2899 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
2900 SvCUR_set(bigstr, offset+len);
2903 i = littlelen - len;
2904 if (i > 0) { /* string might grow */
2905 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
2906 mid = big + offset + len;
2907 midend = bigend = big + SvCUR(bigstr);
2910 while (midend > mid) /* shove everything down */
2911 *--bigend = *--midend;
2912 Move(little,big+offset,littlelen,char);
2918 Move(little,SvPVX(bigstr)+offset,len,char);
2923 big = SvPVX(bigstr);
2926 bigend = big + SvCUR(bigstr);
2928 if (midend > bigend)
2929 Perl_croak(aTHX_ "panic: sv_insert");
2931 if (mid - big > bigend - midend) { /* faster to shorten from end */
2933 Move(little, mid, littlelen,char);
2936 i = bigend - midend;
2938 Move(midend, mid, i,char);
2942 SvCUR_set(bigstr, mid - big);
2945 else if (i = mid - big) { /* faster from front */
2946 midend -= littlelen;
2948 sv_chop(bigstr,midend-i);
2953 Move(little, mid, littlelen,char);
2955 else if (littlelen) {
2956 midend -= littlelen;
2957 sv_chop(bigstr,midend);
2958 Move(little,midend,littlelen,char);
2961 sv_chop(bigstr,midend);
2966 /* make sv point to what nstr did */
2969 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
2972 U32 refcnt = SvREFCNT(sv);
2973 SV_CHECK_THINKFIRST(sv);
2974 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
2975 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
2976 if (SvMAGICAL(sv)) {
2980 sv_upgrade(nsv, SVt_PVMG);
2981 SvMAGIC(nsv) = SvMAGIC(sv);
2982 SvFLAGS(nsv) |= SvMAGICAL(sv);
2988 assert(!SvREFCNT(sv));
2989 StructCopy(nsv,sv,SV);
2990 SvREFCNT(sv) = refcnt;
2991 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
2996 Perl_sv_clear(pTHX_ register SV *sv)
3000 assert(SvREFCNT(sv) == 0);
3004 if (PL_defstash) { /* Still have a symbol table? */
3009 Zero(&tmpref, 1, SV);
3010 sv_upgrade(&tmpref, SVt_RV);
3012 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3013 SvREFCNT(&tmpref) = 1;
3016 stash = SvSTASH(sv);
3017 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3020 PUSHSTACKi(PERLSI_DESTROY);
3021 SvRV(&tmpref) = SvREFCNT_inc(sv);
3026 call_sv((SV*)GvCV(destructor),
3027 G_DISCARD|G_EVAL|G_KEEPERR);
3033 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3035 del_XRV(SvANY(&tmpref));
3038 if (PL_in_clean_objs)
3039 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3041 /* DESTROY gave object new lease on life */
3047 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3048 SvOBJECT_off(sv); /* Curse the object. */
3049 if (SvTYPE(sv) != SVt_PVIO)
3050 --PL_sv_objcount; /* XXX Might want something more general */
3053 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3056 switch (SvTYPE(sv)) {
3059 IoIFP(sv) != PerlIO_stdin() &&
3060 IoIFP(sv) != PerlIO_stdout() &&
3061 IoIFP(sv) != PerlIO_stderr())
3066 PerlDir_close(IoDIRP(sv));
3069 Safefree(IoTOP_NAME(sv));
3070 Safefree(IoFMT_NAME(sv));
3071 Safefree(IoBOTTOM_NAME(sv));
3086 SvREFCNT_dec(LvTARG(sv));
3090 Safefree(GvNAME(sv));
3091 /* cannot decrease stash refcount yet, as we might recursively delete
3092 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3093 of stash until current sv is completely gone.
3094 -- JohnPC, 27 Mar 1998 */
3095 stash = GvSTASH(sv);
3101 (void)SvOOK_off(sv);
3109 SvREFCNT_dec(SvRV(sv));
3111 else if (SvPVX(sv) && SvLEN(sv))
3112 Safefree(SvPVX(sv));
3122 switch (SvTYPE(sv)) {
3138 del_XPVIV(SvANY(sv));
3141 del_XPVNV(SvANY(sv));
3144 del_XPVMG(SvANY(sv));
3147 del_XPVLV(SvANY(sv));
3150 del_XPVAV(SvANY(sv));
3153 del_XPVHV(SvANY(sv));
3156 del_XPVCV(SvANY(sv));
3159 del_XPVGV(SvANY(sv));
3160 /* code duplication for increased performance. */
3161 SvFLAGS(sv) &= SVf_BREAK;
3162 SvFLAGS(sv) |= SVTYPEMASK;
3163 /* decrease refcount of the stash that owns this GV, if any */
3165 SvREFCNT_dec(stash);
3166 return; /* not break, SvFLAGS reset already happened */
3168 del_XPVBM(SvANY(sv));
3171 del_XPVFM(SvANY(sv));
3174 del_XPVIO(SvANY(sv));
3177 SvFLAGS(sv) &= SVf_BREAK;
3178 SvFLAGS(sv) |= SVTYPEMASK;
3182 Perl_sv_newref(pTHX_ SV *sv)
3185 ATOMIC_INC(SvREFCNT(sv));
3190 Perl_sv_free(pTHX_ SV *sv)
3193 int refcount_is_zero;
3197 if (SvREFCNT(sv) == 0) {
3198 if (SvFLAGS(sv) & SVf_BREAK)
3200 if (PL_in_clean_all) /* All is fair */
3202 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3203 /* make sure SvREFCNT(sv)==0 happens very seldom */
3204 SvREFCNT(sv) = (~(U32)0)/2;
3207 if (ckWARN_d(WARN_INTERNAL))
3208 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3211 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3212 if (!refcount_is_zero)
3216 if (ckWARN_d(WARN_DEBUGGING))
3217 Perl_warner(aTHX_ WARN_DEBUGGING,
3218 "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3222 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3223 /* make sure SvREFCNT(sv)==0 happens very seldom */
3224 SvREFCNT(sv) = (~(U32)0)/2;
3233 Perl_sv_len(pTHX_ register SV *sv)
3242 len = mg_length(sv);
3244 junk = SvPV(sv, len);
3249 Perl_sv_len_utf8(pTHX_ register SV *sv)
3260 len = mg_length(sv);
3263 s = (U8*)SvPV(sv, len);
3274 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3279 I32 uoffset = *offsetp;
3285 start = s = (U8*)SvPV(sv, len);
3287 while (s < send && uoffset--)
3291 *offsetp = s - start;
3295 while (s < send && ulen--)
3305 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3314 s = (U8*)SvPV(sv, len);
3316 Perl_croak(aTHX_ "panic: bad byte offset");
3317 send = s + *offsetp;
3325 if (ckWARN_d(WARN_UTF8))
3326 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3334 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3346 pv1 = SvPV(str1, cur1);
3351 pv2 = SvPV(str2, cur2);
3356 return memEQ(pv1, pv2, cur1);
3360 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3363 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3365 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3369 return cur2 ? -1 : 0;
3374 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3377 return retval < 0 ? -1 : 1;
3382 return cur1 < cur2 ? -1 : 1;
3386 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3388 #ifdef USE_LOCALE_COLLATE
3394 if (PL_collation_standard)
3398 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3400 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3402 if (!pv1 || !len1) {
3413 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3416 return retval < 0 ? -1 : 1;
3419 * When the result of collation is equality, that doesn't mean
3420 * that there are no differences -- some locales exclude some
3421 * characters from consideration. So to avoid false equalities,
3422 * we use the raw string as a tiebreaker.
3428 #endif /* USE_LOCALE_COLLATE */
3430 return sv_cmp(sv1, sv2);
3433 #ifdef USE_LOCALE_COLLATE
3435 * Any scalar variable may carry an 'o' magic that contains the
3436 * scalar data of the variable transformed to such a format that
3437 * a normal memory comparison can be used to compare the data
3438 * according to the locale settings.
3441 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3445 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3446 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3451 Safefree(mg->mg_ptr);
3453 if ((xf = mem_collxfrm(s, len, &xlen))) {
3454 if (SvREADONLY(sv)) {
3457 return xf + sizeof(PL_collation_ix);
3460 sv_magic(sv, 0, 'o', 0, 0);
3461 mg = mg_find(sv, 'o');
3474 if (mg && mg->mg_ptr) {
3476 return mg->mg_ptr + sizeof(PL_collation_ix);
3484 #endif /* USE_LOCALE_COLLATE */
3487 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3492 register STDCHAR rslast;
3493 register STDCHAR *bp;
3497 SV_CHECK_THINKFIRST(sv);
3498 (void)SvUPGRADE(sv, SVt_PV);
3502 if (RsSNARF(PL_rs)) {
3506 else if (RsRECORD(PL_rs)) {
3507 I32 recsize, bytesread;
3510 /* Grab the size of the record we're getting */
3511 recsize = SvIV(SvRV(PL_rs));
3512 (void)SvPOK_only(sv); /* Validate pointer */
3513 buffer = SvGROW(sv, recsize + 1);
3516 /* VMS wants read instead of fread, because fread doesn't respect */
3517 /* RMS record boundaries. This is not necessarily a good thing to be */
3518 /* doing, but we've got no other real choice */
3519 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3521 bytesread = PerlIO_read(fp, buffer, recsize);
3523 SvCUR_set(sv, bytesread);
3524 buffer[bytesread] = '\0';
3525 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3527 else if (RsPARA(PL_rs)) {
3532 rsptr = SvPV(PL_rs, rslen);
3533 rslast = rslen ? rsptr[rslen - 1] : '\0';
3535 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3536 do { /* to make sure file boundaries work right */
3539 i = PerlIO_getc(fp);
3543 PerlIO_ungetc(fp,i);
3549 /* See if we know enough about I/O mechanism to cheat it ! */
3551 /* This used to be #ifdef test - it is made run-time test for ease
3552 of abstracting out stdio interface. One call should be cheap
3553 enough here - and may even be a macro allowing compile
3557 if (PerlIO_fast_gets(fp)) {
3560 * We're going to steal some values from the stdio struct
3561 * and put EVERYTHING in the innermost loop into registers.
3563 register STDCHAR *ptr;
3567 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3568 /* An ungetc()d char is handled separately from the regular
3569 * buffer, so we getc() it back out and stuff it in the buffer.
3571 i = PerlIO_getc(fp);
3572 if (i == EOF) return 0;
3573 *(--((*fp)->_ptr)) = (unsigned char) i;
3577 /* Here is some breathtakingly efficient cheating */
3579 cnt = PerlIO_get_cnt(fp); /* get count into register */
3580 (void)SvPOK_only(sv); /* validate pointer */
3581 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3582 if (cnt > 80 && SvLEN(sv) > append) {
3583 shortbuffered = cnt - SvLEN(sv) + append + 1;
3584 cnt -= shortbuffered;
3588 /* remember that cnt can be negative */
3589 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3594 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3595 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3596 DEBUG_P(PerlIO_printf(Perl_debug_log,
3597 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3598 DEBUG_P(PerlIO_printf(Perl_debug_log,
3599 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3600 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3601 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3606 while (cnt > 0) { /* this | eat */
3608 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3609 goto thats_all_folks; /* screams | sed :-) */
3613 Copy(ptr, bp, cnt, char); /* this | eat */
3614 bp += cnt; /* screams | dust */
3615 ptr += cnt; /* louder | sed :-) */
3620 if (shortbuffered) { /* oh well, must extend */
3621 cnt = shortbuffered;
3623 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3625 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3626 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3630 DEBUG_P(PerlIO_printf(Perl_debug_log,
3631 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3632 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3633 DEBUG_P(PerlIO_printf(Perl_debug_log,
3634 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3635 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3636 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3637 /* This used to call 'filbuf' in stdio form, but as that behaves like
3638 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3639 another abstraction. */
3640 i = PerlIO_getc(fp); /* get more characters */
3641 DEBUG_P(PerlIO_printf(Perl_debug_log,
3642 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3643 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3644 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3645 cnt = PerlIO_get_cnt(fp);
3646 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3647 DEBUG_P(PerlIO_printf(Perl_debug_log,
3648 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3650 if (i == EOF) /* all done for ever? */
3651 goto thats_really_all_folks;
3653 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3655 SvGROW(sv, bpx + cnt + 2);
3656 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3658 *bp++ = i; /* store character from PerlIO_getc */
3660 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3661 goto thats_all_folks;
3665 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3666 memNE((char*)bp - rslen, rsptr, rslen))
3667 goto screamer; /* go back to the fray */
3668 thats_really_all_folks:
3670 cnt += shortbuffered;
3671 DEBUG_P(PerlIO_printf(Perl_debug_log,
3672 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3673 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3674 DEBUG_P(PerlIO_printf(Perl_debug_log,
3675 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3676 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3677 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3679 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3680 DEBUG_P(PerlIO_printf(Perl_debug_log,
3681 "Screamer: done, len=%ld, string=|%.*s|\n",
3682 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3687 /*The big, slow, and stupid way */
3690 /* Need to work around EPOC SDK features */
3691 /* On WINS: MS VC5 generates calls to _chkstk, */
3692 /* if a `large' stack frame is allocated */
3693 /* gcc on MARM does not generate calls like these */
3699 register STDCHAR *bpe = buf + sizeof(buf);
3701 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3702 ; /* keep reading */
3706 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3707 /* Accomodate broken VAXC compiler, which applies U8 cast to
3708 * both args of ?: operator, causing EOF to change into 255
3710 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3714 sv_catpvn(sv, (char *) buf, cnt);
3716 sv_setpvn(sv, (char *) buf, cnt);
3718 if (i != EOF && /* joy */
3720 SvCUR(sv) < rslen ||
3721 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3725 * If we're reading from a TTY and we get a short read,
3726 * indicating that the user hit his EOF character, we need
3727 * to notice it now, because if we try to read from the TTY
3728 * again, the EOF condition will disappear.
3730 * The comparison of cnt to sizeof(buf) is an optimization
3731 * that prevents unnecessary calls to feof().
3735 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3740 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3741 while (i != EOF) { /* to make sure file boundaries work right */
3742 i = PerlIO_getc(fp);
3744 PerlIO_ungetc(fp,i);
3751 win32_strip_return(sv);
3754 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
3759 Perl_sv_inc(pTHX_ register SV *sv)
3768 if (SvTHINKFIRST(sv)) {
3769 if (SvREADONLY(sv)) {
3771 if (PL_curcop != &PL_compiling)
3772 Perl_croak(aTHX_ PL_no_modify);
3776 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
3783 flags = SvFLAGS(sv);
3784 if (flags & SVp_NOK) {
3785 (void)SvNOK_only(sv);
3789 if (flags & SVp_IOK) {
3791 if (SvUVX(sv) == UV_MAX)
3792 sv_setnv(sv, (NV)UV_MAX + 1.0);
3794 (void)SvIOK_only_UV(sv);
3797 if (SvIVX(sv) == IV_MAX)
3798 sv_setnv(sv, (NV)IV_MAX + 1.0);
3800 (void)SvIOK_only(sv);
3806 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
3807 if ((flags & SVTYPEMASK) < SVt_PVNV)
3808 sv_upgrade(sv, SVt_NV);
3810 (void)SvNOK_only(sv);
3814 while (isALPHA(*d)) d++;
3815 while (isDIGIT(*d)) d++;
3817 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
3821 while (d >= SvPVX(sv)) {
3829 /* MKS: The original code here died if letters weren't consecutive.
3830 * at least it didn't have to worry about non-C locales. The
3831 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
3832 * arranged in order (although not consecutively) and that only
3833 * [A-Za-z] are accepted by isALPHA in the C locale.
3835 if (*d != 'z' && *d != 'Z') {
3836 do { ++*d; } while (!isALPHA(*d));
3839 *(d--) -= 'z' - 'a';
3844 *(d--) -= 'z' - 'a' + 1;
3848 /* oh,oh, the number grew */
3849 SvGROW(sv, SvCUR(sv) + 2);
3851 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
3860 Perl_sv_dec(pTHX_ register SV *sv)
3868 if (SvTHINKFIRST(sv)) {
3869 if (SvREADONLY(sv)) {
3871 if (PL_curcop != &PL_compiling)
3872 Perl_croak(aTHX_ PL_no_modify);
3876 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
3883 flags = SvFLAGS(sv);
3884 if (flags & SVp_NOK) {
3886 (void)SvNOK_only(sv);
3889 if (flags & SVp_IOK) {
3891 if (SvUVX(sv) == 0) {
3892 (void)SvIOK_only(sv);
3896 (void)SvIOK_only_UV(sv);
3900 if (SvIVX(sv) == IV_MIN)
3901 sv_setnv(sv, (NV)IV_MIN - 1.0);
3903 (void)SvIOK_only(sv);
3909 if (!(flags & SVp_POK)) {
3910 if ((flags & SVTYPEMASK) < SVt_PVNV)
3911 sv_upgrade(sv, SVt_NV);
3913 (void)SvNOK_only(sv);
3916 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
3919 /* Make a string that will exist for the duration of the expression
3920 * evaluation. Actually, it may have to last longer than that, but
3921 * hopefully we won't free it until it has been assigned to a
3922 * permanent location. */
3925 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
3931 sv_setsv(sv,oldstr);
3933 PL_tmps_stack[++PL_tmps_ix] = sv;
3939 Perl_sv_newmortal(pTHX)
3945 SvFLAGS(sv) = SVs_TEMP;
3947 PL_tmps_stack[++PL_tmps_ix] = sv;
3951 /* same thing without the copying */
3954 Perl_sv_2mortal(pTHX_ register SV *sv)
3959 if (SvREADONLY(sv) && SvIMMORTAL(sv))
3962 PL_tmps_stack[++PL_tmps_ix] = sv;
3968 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
3975 sv_setpvn(sv,s,len);
3980 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
3985 sv_setpvn(sv,s,len);
3989 #if defined(PERL_IMPLICIT_CONTEXT)
3991 Perl_newSVpvf_nocontext(const char* pat, ...)
3998 va_start(args, pat);
3999 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4006 Perl_newSVpvf(pTHX_ const char* pat, ...)
4012 va_start(args, pat);
4013 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4019 Perl_newSVnv(pTHX_ NV n)
4029 Perl_newSViv(pTHX_ IV i)
4039 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4045 sv_upgrade(sv, SVt_RV);
4053 Perl_newRV(pTHX_ SV *tmpRef)
4055 return newRV_noinc(SvREFCNT_inc(tmpRef));
4058 /* make an exact duplicate of old */
4061 Perl_newSVsv(pTHX_ register SV *old)
4068 if (SvTYPE(old) == SVTYPEMASK) {
4069 if (ckWARN_d(WARN_INTERNAL))
4070 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4085 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4098 if (!*s) { /* reset ?? searches */
4099 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4100 pm->op_pmdynflags &= ~PMdf_USED;
4105 /* reset variables */
4107 if (!HvARRAY(stash))
4110 Zero(todo, 256, char);
4117 for ( ; i <= max; i++) {
4120 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4121 for (entry = HvARRAY(stash)[i];
4123 entry = HeNEXT(entry))
4125 if (!todo[(U8)*HeKEY(entry)])
4127 gv = (GV*)HeVAL(entry);
4129 if (SvTHINKFIRST(sv)) {
4130 if (!SvREADONLY(sv) && SvROK(sv))
4135 if (SvTYPE(sv) >= SVt_PV) {
4137 if (SvPVX(sv) != Nullch)
4144 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4146 #ifndef VMS /* VMS has no environ array */
4148 environ[0] = Nullch;
4157 Perl_sv_2io(pTHX_ SV *sv)
4163 switch (SvTYPE(sv)) {
4171 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4175 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4177 return sv_2io(SvRV(sv));
4178 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4184 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4191 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4198 return *gvp = Nullgv, Nullcv;
4199 switch (SvTYPE(sv)) {
4219 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4220 tryAMAGICunDEREF(to_cv);
4223 if (SvTYPE(sv) == SVt_PVCV) {
4232 Perl_croak(aTHX_ "Not a subroutine reference");
4237 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4243 if (lref && !GvCVu(gv)) {
4246 tmpsv = NEWSV(704,0);
4247 gv_efullname3(tmpsv, gv, Nullch);
4248 /* XXX this is probably not what they think they're getting.
4249 * It has the same effect as "sub name;", i.e. just a forward
4251 newSUB(start_subparse(FALSE, 0),
4252 newSVOP(OP_CONST, 0, tmpsv),
4257 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4264 Perl_sv_true(pTHX_ register SV *sv)
4271 if ((tXpv = (XPV*)SvANY(sv)) &&
4272 (*tXpv->xpv_pv > '0' ||
4273 tXpv->xpv_cur > 1 ||
4274 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4281 return SvIVX(sv) != 0;
4284 return SvNVX(sv) != 0.0;
4286 return sv_2bool(sv);
4292 Perl_sv_iv(pTHX_ register SV *sv)
4296 return (IV)SvUVX(sv);
4303 Perl_sv_uv(pTHX_ register SV *sv)
4308 return (UV)SvIVX(sv);
4314 Perl_sv_nv(pTHX_ register SV *sv)
4322 Perl_sv_pv(pTHX_ SV *sv)
4329 return sv_2pv(sv, &n_a);
4333 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4339 return sv_2pv(sv, lp);
4343 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4347 if (SvTHINKFIRST(sv) && !SvROK(sv))
4348 sv_force_normal(sv);
4354 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4356 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4357 PL_op_name[PL_op->op_type]);
4361 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4366 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4367 SvGROW(sv, len + 1);
4368 Move(s,SvPVX(sv),len,char);
4373 SvPOK_on(sv); /* validate pointer */
4375 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4376 (unsigned long)sv,SvPVX(sv)));
4383 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4385 if (ob && SvOBJECT(sv))
4386 return HvNAME(SvSTASH(sv));
4388 switch (SvTYPE(sv)) {
4402 case SVt_PVLV: return "LVALUE";
4403 case SVt_PVAV: return "ARRAY";
4404 case SVt_PVHV: return "HASH";
4405 case SVt_PVCV: return "CODE";
4406 case SVt_PVGV: return "GLOB";
4407 case SVt_PVFM: return "FORMAT";
4408 default: return "UNKNOWN";
4414 Perl_sv_isobject(pTHX_ SV *sv)
4429 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4441 return strEQ(HvNAME(SvSTASH(sv)), name);
4445 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4452 SV_CHECK_THINKFIRST(rv);
4455 if (SvTYPE(rv) < SVt_RV)
4456 sv_upgrade(rv, SVt_RV);
4463 HV* stash = gv_stashpv(classname, TRUE);
4464 (void)sv_bless(rv, stash);
4470 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4473 sv_setsv(rv, &PL_sv_undef);
4477 sv_setiv(newSVrv(rv,classname), (IV)pv);
4482 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4484 sv_setiv(newSVrv(rv,classname), iv);
4489 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4491 sv_setnv(newSVrv(rv,classname), nv);
4496 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4498 sv_setpvn(newSVrv(rv,classname), pv, n);
4503 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4508 Perl_croak(aTHX_ "Can't bless non-reference value");
4510 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4511 if (SvREADONLY(tmpRef))
4512 Perl_croak(aTHX_ PL_no_modify);
4513 if (SvOBJECT(tmpRef)) {
4514 if (SvTYPE(tmpRef) != SVt_PVIO)
4516 SvREFCNT_dec(SvSTASH(tmpRef));
4519 SvOBJECT_on(tmpRef);
4520 if (SvTYPE(tmpRef) != SVt_PVIO)
4522 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4523 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4534 S_sv_unglob(pTHX_ SV *sv)
4536 assert(SvTYPE(sv) == SVt_PVGV);
4541 SvREFCNT_dec(GvSTASH(sv));
4542 GvSTASH(sv) = Nullhv;
4544 sv_unmagic(sv, '*');
4545 Safefree(GvNAME(sv));
4547 SvFLAGS(sv) &= ~SVTYPEMASK;
4548 SvFLAGS(sv) |= SVt_PVMG;
4552 Perl_sv_unref(pTHX_ SV *sv)
4556 if (SvWEAKREF(sv)) {
4564 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4567 sv_2mortal(rv); /* Schedule for freeing later */
4571 Perl_sv_taint(pTHX_ SV *sv)
4573 sv_magic((sv), Nullsv, 't', Nullch, 0);
4577 Perl_sv_untaint(pTHX_ SV *sv)
4579 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4580 MAGIC *mg = mg_find(sv, 't');
4587 Perl_sv_tainted(pTHX_ SV *sv)
4589 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4590 MAGIC *mg = mg_find(sv, 't');
4591 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4598 Perl_sv_setpviv(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);
4609 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4611 char buf[TYPE_CHARS(UV)];
4613 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4615 sv_setpvn(sv, ptr, ebuf - ptr);
4619 #if defined(PERL_IMPLICIT_CONTEXT)
4621 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4625 va_start(args, pat);
4626 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4632 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4636 va_start(args, pat);
4637 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4644 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4647 va_start(args, pat);
4648 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4654 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4657 va_start(args, pat);
4658 sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4663 #if defined(PERL_IMPLICIT_CONTEXT)
4665 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4669 va_start(args, pat);
4670 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4675 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4679 va_start(args, pat);
4680 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4687 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4690 va_start(args, pat);
4691 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4696 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4699 va_start(args, pat);
4700 sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*));
4706 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4708 sv_setpvn(sv, "", 0);
4709 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, used_locale);
4713 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *used_locale)
4721 static char nullstr[] = "(null)";
4723 /* no matter what, this is a string now */
4724 (void)SvPV_force(sv, origlen);
4726 /* special-case "", "%s", and "%_" */
4729 if (patlen == 2 && pat[0] == '%') {
4733 char *s = va_arg(*args, char*);
4734 sv_catpv(sv, s ? s : nullstr);
4736 else if (svix < svmax)
4737 sv_catsv(sv, *svargs);
4741 sv_catsv(sv, va_arg(*args, SV*));
4744 /* See comment on '_' below */
4749 patend = (char*)pat + patlen;
4750 for (p = (char*)pat; p < patend; p = q) {
4758 bool has_precis = FALSE;
4763 STRLEN esignlen = 0;
4765 char *eptr = Nullch;
4767 char ebuf[TYPE_DIGITS(int) * 2 + 16]; /* large enough for "%#.#f" */
4778 for (q = p; q < patend && *q != '%'; ++q) ;
4780 sv_catpvn(sv, p, q - p);
4818 case '1': case '2': case '3':
4819 case '4': case '5': case '6':
4820 case '7': case '8': case '9':
4823 width = width * 10 + (*q++ - '0');
4828 i = va_arg(*args, int);
4830 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4832 width = (i < 0) ? -i : i;
4843 i = va_arg(*args, int);
4845 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4846 precis = (i < 0) ? 0 : i;
4852 precis = precis * 10 + (*q++ - '0');
4861 #if 0 /* when quads have better support within Perl */
4862 if (*(q + 1) == 'l') {
4889 uv = va_arg(*args, int);
4891 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4893 eptr = (char*)utf8buf;
4894 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
4898 c = va_arg(*args, int);
4900 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4907 eptr = va_arg(*args, char*);
4909 elen = strlen(eptr);
4912 elen = sizeof nullstr - 1;
4915 else if (svix < svmax) {
4916 eptr = SvPVx(svargs[svix++], elen);
4918 if (has_precis && precis < elen) {
4920 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
4923 if (width) { /* fudge width (can't fudge elen) */
4924 width += elen - sv_len_utf8(svargs[svix - 1]);
4932 * The "%_" hack might have to be changed someday,
4933 * if ISO or ANSI decide to use '_' for something.
4934 * So we keep it hidden from users' code.
4938 eptr = SvPVx(va_arg(*args, SV*), elen);
4941 if (has_precis && elen > precis)
4949 uv = (UV)va_arg(*args, void*);
4951 uv = (svix < svmax) ? (UV)svargs[svix++] : 0;
4962 case 'h': iv = (short)va_arg(*args, int); break;
4963 default: iv = va_arg(*args, int); break;
4964 case 'l': iv = va_arg(*args, long); break;
4965 case 'V': iv = va_arg(*args, IV); break;
4969 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
4971 case 'h': iv = (short)iv; break;
4972 default: iv = (int)iv; break;
4973 case 'l': iv = (long)iv; break;
4980 esignbuf[esignlen++] = plus;
4984 esignbuf[esignlen++] = '-';
5014 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5015 default: uv = va_arg(*args, unsigned); break;
5016 case 'l': uv = va_arg(*args, unsigned long); break;
5017 case 'V': uv = va_arg(*args, UV); break;
5021 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5023 case 'h': uv = (unsigned short)uv; break;
5024 default: uv = (unsigned)uv; break;
5025 case 'l': uv = (unsigned long)uv; break;
5031 eptr = ebuf + sizeof ebuf;
5037 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5043 esignbuf[esignlen++] = '0';
5044 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5050 *--eptr = '0' + dig;
5052 if (alt && *eptr != '0')
5058 *--eptr = '0' + dig;
5060 if (alt && *eptr != '0')
5063 default: /* it had better be ten or less */
5066 *--eptr = '0' + dig;
5067 } while (uv /= base);
5070 elen = (ebuf + sizeof ebuf) - eptr;
5073 zeros = precis - elen;
5074 else if (precis == 0 && elen == 1 && *eptr == '0')
5079 /* FLOATING POINT */
5082 c = 'f'; /* maybe %F isn't supported here */
5088 /* This is evil, but floating point is even more evil */
5091 nv = va_arg(*args, NV);
5093 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5096 if (c != 'e' && c != 'E') {
5098 (void)frexp(nv, &i);
5099 if (i == PERL_INT_MIN)
5100 Perl_die(aTHX_ "panic: frexp");
5102 need = BIT_DIGITS(i);
5104 need += has_precis ? precis : 6; /* known default */
5108 need += 20; /* fudge factor */
5109 if (PL_efloatsize < need) {
5110 Safefree(PL_efloatbuf);
5111 PL_efloatsize = need + 20; /* more fudge */
5112 New(906, PL_efloatbuf, PL_efloatsize, char);
5115 eptr = ebuf + sizeof ebuf;
5118 #ifdef USE_LONG_DOUBLE
5123 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5128 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5141 RESTORE_NUMERIC_STANDARD();
5142 (void)sprintf(PL_efloatbuf, eptr, nv);
5143 RESTORE_NUMERIC_LOCAL();
5146 eptr = PL_efloatbuf;
5147 elen = strlen(PL_efloatbuf);
5151 * User-defined locales may include arbitrary characters.
5152 * And, unfortunately, some system may alloc the "C" locale
5153 * to be overridden by a malicious user.
5156 *used_locale = TRUE;
5157 #endif /* LC_NUMERIC */
5164 i = SvCUR(sv) - origlen;
5167 case 'h': *(va_arg(*args, short*)) = i; break;
5168 default: *(va_arg(*args, int*)) = i; break;
5169 case 'l': *(va_arg(*args, long*)) = i; break;
5170 case 'V': *(va_arg(*args, IV*)) = i; break;
5173 else if (svix < svmax)
5174 sv_setuv(svargs[svix++], (UV)i);
5175 continue; /* not "break" */
5181 if (!args && ckWARN(WARN_PRINTF) &&
5182 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5183 SV *msg = sv_newmortal();
5184 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5185 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5187 Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"",
5190 sv_catpv(msg, "end of string");
5191 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5194 /* output mangled stuff ... */
5200 /* ... right here, because formatting flags should not apply */
5201 SvGROW(sv, SvCUR(sv) + elen + 1);
5203 memcpy(p, eptr, elen);
5206 SvCUR(sv) = p - SvPVX(sv);
5207 continue; /* not "break" */
5210 have = esignlen + zeros + elen;
5211 need = (have > width ? have : width);
5214 SvGROW(sv, SvCUR(sv) + need + 1);
5216 if (esignlen && fill == '0') {
5217 for (i = 0; i < esignlen; i++)
5221 memset(p, fill, gap);
5224 if (esignlen && fill != '0') {
5225 for (i = 0; i < esignlen; i++)
5229 for (i = zeros; i; i--)
5233 memcpy(p, eptr, elen);
5237 memset(p, ' ', gap);
5241 SvCUR(sv) = p - SvPVX(sv);