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 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
34 (p) = (SV*)safemalloc(sizeof(SV)); \
46 Safefree((char*)(p)); \
51 static I32 registry_size;
53 #define REGHASH(sv,size) ((((U32)(sv)) >> 2) % (size))
55 #define REG_REPLACE(sv,a,b) \
57 void* p = sv->sv_any; \
58 I32 h = REGHASH(sv, registry_size); \
60 while (registry[i] != (a)) { \
61 if (++i >= registry_size) \
64 Perl_die(aTHX_ "SV registry bug"); \
69 #define REG_ADD(sv) REG_REPLACE(sv,Nullsv,sv)
70 #define REG_REMOVE(sv) REG_REPLACE(sv,sv,Nullsv)
73 S_reg_add(pTHX_ SV *sv)
75 if (PL_sv_count >= (registry_size >> 1))
77 SV **oldreg = registry;
78 I32 oldsize = registry_size;
80 registry_size = registry_size ? ((registry_size << 2) + 1) : 2037;
81 Newz(707, registry, registry_size, SV*);
86 for (i = 0; i < oldsize; ++i) {
87 SV* oldsv = oldreg[i];
100 S_reg_remove(pTHX_ SV *sv)
107 S_visit(pTHX_ SVFUNC_t f)
111 for (i = 0; i < registry_size; ++i) {
112 SV* sv = registry[i];
113 if (sv && SvTYPE(sv) != SVTYPEMASK)
119 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
121 if (!(flags & SVf_FAKE))
128 * "A time to plant, and a time to uproot what was planted..."
131 #define plant_SV(p) \
133 SvANY(p) = (void *)PL_sv_root; \
134 SvFLAGS(p) = SVTYPEMASK; \
139 /* sv_mutex must be held while calling uproot_SV() */
140 #define uproot_SV(p) \
143 PL_sv_root = (SV*)SvANY(p); \
165 if (PL_debug & 32768) \
173 S_del_sv(pTHX_ SV *p)
175 if (PL_debug & 32768) {
180 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
182 svend = &sva[SvREFCNT(sva)];
183 if (p >= sv && p < svend)
187 if (ckWARN_d(WARN_INTERNAL))
188 Perl_warner(aTHX_ WARN_INTERNAL,
189 "Attempt to free non-arena SV: 0x%lx", (unsigned long)p);
196 #else /* ! DEBUGGING */
198 #define del_SV(p) plant_SV(p)
200 #endif /* DEBUGGING */
203 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
208 Zero(sva, size, char);
210 /* The first SV in an arena isn't an SV. */
211 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
212 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
213 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
215 PL_sv_arenaroot = sva;
216 PL_sv_root = sva + 1;
218 svend = &sva[SvREFCNT(sva) - 1];
221 SvANY(sv) = (void *)(SV*)(sv + 1);
222 SvFLAGS(sv) = SVTYPEMASK;
226 SvFLAGS(sv) = SVTYPEMASK;
229 /* sv_mutex must be held while calling more_sv() */
236 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
237 PL_nice_chunk = Nullch;
240 char *chunk; /* must use New here to match call to */
241 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
242 sv_add_arena(chunk, 1008, 0);
249 S_visit(pTHX_ SVFUNC_t f)
255 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
256 svend = &sva[SvREFCNT(sva)];
257 for (sv = sva + 1; sv < svend; ++sv) {
258 if (SvTYPE(sv) != SVTYPEMASK)
267 Perl_sv_report_used(pTHX)
269 visit(do_report_used);
273 Perl_sv_clean_objs(pTHX)
275 PL_in_clean_objs = TRUE;
276 visit(do_clean_objs);
277 #ifndef DISABLE_DESTRUCTOR_KLUDGE
278 /* some barnacles may yet remain, clinging to typeglobs */
279 visit(do_clean_named_objs);
281 PL_in_clean_objs = FALSE;
285 Perl_sv_clean_all(pTHX)
287 PL_in_clean_all = TRUE;
289 PL_in_clean_all = FALSE;
293 Perl_sv_free_arenas(pTHX)
298 /* Free arenas here, but be careful about fake ones. (We assume
299 contiguity of the fake ones with the corresponding real ones.) */
301 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
302 svanext = (SV*) SvANY(sva);
303 while (svanext && SvFAKE(svanext))
304 svanext = (SV*) SvANY(svanext);
307 Safefree((void *)sva);
311 Safefree(PL_nice_chunk);
312 PL_nice_chunk = Nullch;
313 PL_nice_chunk_size = 0;
327 * See comment in more_xiv() -- RAM.
329 PL_xiv_root = *(IV**)xiv;
331 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
335 S_del_xiv(pTHX_ XPVIV *p)
337 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
339 *(IV**)xiv = PL_xiv_root;
350 New(705, ptr, 1008/sizeof(XPV), XPV);
351 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
352 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
355 xivend = &xiv[1008 / sizeof(IV) - 1];
356 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
358 while (xiv < xivend) {
359 *(IV**)xiv = (IV *)(xiv + 1);
373 PL_xnv_root = *(NV**)xnv;
375 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
379 S_del_xnv(pTHX_ XPVNV *p)
381 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
383 *(NV**)xnv = PL_xnv_root;
393 New(711, xnv, 1008/sizeof(NV), NV);
394 xnvend = &xnv[1008 / sizeof(NV) - 1];
395 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
397 while (xnv < xnvend) {
398 *(NV**)xnv = (NV*)(xnv + 1);
412 PL_xrv_root = (XRV*)xrv->xrv_rv;
418 S_del_xrv(pTHX_ XRV *p)
421 p->xrv_rv = (SV*)PL_xrv_root;
430 register XRV* xrvend;
431 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
433 xrvend = &xrv[1008 / sizeof(XRV) - 1];
434 while (xrv < xrvend) {
435 xrv->xrv_rv = (SV*)(xrv + 1);
449 PL_xpv_root = (XPV*)xpv->xpv_pv;
455 S_del_xpv(pTHX_ XPV *p)
458 p->xpv_pv = (char*)PL_xpv_root;
467 register XPV* xpvend;
468 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
470 xpvend = &xpv[1008 / sizeof(XPV) - 1];
471 while (xpv < xpvend) {
472 xpv->xpv_pv = (char*)(xpv + 1);
485 xpviv = PL_xpviv_root;
486 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
492 S_del_xpviv(pTHX_ XPVIV *p)
495 p->xpv_pv = (char*)PL_xpviv_root;
504 register XPVIV* xpviv;
505 register XPVIV* xpvivend;
506 New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
507 xpviv = PL_xpviv_root;
508 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
509 while (xpviv < xpvivend) {
510 xpviv->xpv_pv = (char*)(xpviv + 1);
524 xpvnv = PL_xpvnv_root;
525 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
531 S_del_xpvnv(pTHX_ XPVNV *p)
534 p->xpv_pv = (char*)PL_xpvnv_root;
543 register XPVNV* xpvnv;
544 register XPVNV* xpvnvend;
545 New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
546 xpvnv = PL_xpvnv_root;
547 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
548 while (xpvnv < xpvnvend) {
549 xpvnv->xpv_pv = (char*)(xpvnv + 1);
564 xpvcv = PL_xpvcv_root;
565 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
571 S_del_xpvcv(pTHX_ XPVCV *p)
574 p->xpv_pv = (char*)PL_xpvcv_root;
583 register XPVCV* xpvcv;
584 register XPVCV* xpvcvend;
585 New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
586 xpvcv = PL_xpvcv_root;
587 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
588 while (xpvcv < xpvcvend) {
589 xpvcv->xpv_pv = (char*)(xpvcv + 1);
604 xpvav = PL_xpvav_root;
605 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
611 S_del_xpvav(pTHX_ XPVAV *p)
614 p->xav_array = (char*)PL_xpvav_root;
623 register XPVAV* xpvav;
624 register XPVAV* xpvavend;
625 New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
626 xpvav = PL_xpvav_root;
627 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
628 while (xpvav < xpvavend) {
629 xpvav->xav_array = (char*)(xpvav + 1);
632 xpvav->xav_array = 0;
644 xpvhv = PL_xpvhv_root;
645 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
651 S_del_xpvhv(pTHX_ XPVHV *p)
654 p->xhv_array = (char*)PL_xpvhv_root;
663 register XPVHV* xpvhv;
664 register XPVHV* xpvhvend;
665 New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
666 xpvhv = PL_xpvhv_root;
667 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
668 while (xpvhv < xpvhvend) {
669 xpvhv->xhv_array = (char*)(xpvhv + 1);
672 xpvhv->xhv_array = 0;
683 xpvmg = PL_xpvmg_root;
684 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
690 S_del_xpvmg(pTHX_ XPVMG *p)
693 p->xpv_pv = (char*)PL_xpvmg_root;
702 register XPVMG* xpvmg;
703 register XPVMG* xpvmgend;
704 New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
705 xpvmg = PL_xpvmg_root;
706 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
707 while (xpvmg < xpvmgend) {
708 xpvmg->xpv_pv = (char*)(xpvmg + 1);
723 xpvlv = PL_xpvlv_root;
724 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
730 S_del_xpvlv(pTHX_ XPVLV *p)
733 p->xpv_pv = (char*)PL_xpvlv_root;
742 register XPVLV* xpvlv;
743 register XPVLV* xpvlvend;
744 New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
745 xpvlv = PL_xpvlv_root;
746 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
747 while (xpvlv < xpvlvend) {
748 xpvlv->xpv_pv = (char*)(xpvlv + 1);
762 xpvbm = PL_xpvbm_root;
763 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
769 S_del_xpvbm(pTHX_ XPVBM *p)
772 p->xpv_pv = (char*)PL_xpvbm_root;
781 register XPVBM* xpvbm;
782 register XPVBM* xpvbmend;
783 New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
784 xpvbm = PL_xpvbm_root;
785 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
786 while (xpvbm < xpvbmend) {
787 xpvbm->xpv_pv = (char*)(xpvbm + 1);
794 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
795 #define del_XIV(p) Safefree((char*)p)
797 #define new_XIV() (void*)new_xiv()
798 #define del_XIV(p) del_xiv((XPVIV*) p)
802 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
803 #define del_XNV(p) Safefree((char*)p)
805 #define new_XNV() (void*)new_xnv()
806 #define del_XNV(p) del_xnv((XPVNV*) p)
810 #define new_XRV() (void*)safemalloc(sizeof(XRV))
811 #define del_XRV(p) Safefree((char*)p)
813 #define new_XRV() (void*)new_xrv()
814 #define del_XRV(p) del_xrv((XRV*) p)
818 #define new_XPV() (void*)safemalloc(sizeof(XPV))
819 #define del_XPV(p) Safefree((char*)p)
821 #define new_XPV() (void*)new_xpv()
822 #define del_XPV(p) del_xpv((XPV *)p)
826 # define my_safemalloc(s) safemalloc(s)
827 # define my_safefree(s) safefree(s)
830 S_my_safemalloc(MEM_SIZE size)
833 New(717, p, size, char);
836 # define my_safefree(s) Safefree(s)
840 #define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
841 #define del_XPVIV(p) Safefree((char*)p)
843 #define new_XPVIV() (void*)new_xpviv()
844 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
848 #define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
849 #define del_XPVNV(p) Safefree((char*)p)
851 #define new_XPVNV() (void*)new_xpvnv()
852 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
857 #define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
858 #define del_XPVCV(p) Safefree((char*)p)
860 #define new_XPVCV() (void*)new_xpvcv()
861 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
865 #define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
866 #define del_XPVAV(p) Safefree((char*)p)
868 #define new_XPVAV() (void*)new_xpvav()
869 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
873 #define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
874 #define del_XPVHV(p) Safefree((char*)p)
876 #define new_XPVHV() (void*)new_xpvhv()
877 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
881 #define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
882 #define del_XPVMG(p) Safefree((char*)p)
884 #define new_XPVMG() (void*)new_xpvmg()
885 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
889 #define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
890 #define del_XPVLV(p) Safefree((char*)p)
892 #define new_XPVLV() (void*)new_xpvlv()
893 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
896 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
897 #define del_XPVGV(p) my_safefree((char*)p)
900 #define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
901 #define del_XPVBM(p) Safefree((char*)p)
903 #define new_XPVBM() (void*)new_xpvbm()
904 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
907 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
908 #define del_XPVFM(p) my_safefree((char*)p)
910 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
911 #define del_XPVIO(p) my_safefree((char*)p)
914 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
924 if (SvTYPE(sv) == mt)
930 switch (SvTYPE(sv)) {
951 else if (mt < SVt_PVIV)
968 pv = (char*)SvRV(sv);
988 else if (mt == SVt_NV)
999 del_XPVIV(SvANY(sv));
1009 del_XPVNV(SvANY(sv));
1017 magic = SvMAGIC(sv);
1018 stash = SvSTASH(sv);
1019 del_XPVMG(SvANY(sv));
1022 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1027 Perl_croak(aTHX_ "Can't upgrade to undef");
1029 SvANY(sv) = new_XIV();
1033 SvANY(sv) = new_XNV();
1037 SvANY(sv) = new_XRV();
1041 SvANY(sv) = new_XPV();
1047 SvANY(sv) = new_XPVIV();
1057 SvANY(sv) = new_XPVNV();
1065 SvANY(sv) = new_XPVMG();
1071 SvMAGIC(sv) = magic;
1072 SvSTASH(sv) = stash;
1075 SvANY(sv) = new_XPVLV();
1081 SvMAGIC(sv) = magic;
1082 SvSTASH(sv) = stash;
1089 SvANY(sv) = new_XPVAV();
1097 SvMAGIC(sv) = magic;
1098 SvSTASH(sv) = stash;
1104 SvANY(sv) = new_XPVHV();
1112 SvMAGIC(sv) = magic;
1113 SvSTASH(sv) = stash;
1120 SvANY(sv) = new_XPVCV();
1121 Zero(SvANY(sv), 1, XPVCV);
1127 SvMAGIC(sv) = magic;
1128 SvSTASH(sv) = stash;
1131 SvANY(sv) = new_XPVGV();
1137 SvMAGIC(sv) = magic;
1138 SvSTASH(sv) = stash;
1146 SvANY(sv) = new_XPVBM();
1152 SvMAGIC(sv) = magic;
1153 SvSTASH(sv) = stash;
1159 SvANY(sv) = new_XPVFM();
1160 Zero(SvANY(sv), 1, XPVFM);
1166 SvMAGIC(sv) = magic;
1167 SvSTASH(sv) = stash;
1170 SvANY(sv) = new_XPVIO();
1171 Zero(SvANY(sv), 1, XPVIO);
1177 SvMAGIC(sv) = magic;
1178 SvSTASH(sv) = stash;
1179 IoPAGE_LEN(sv) = 60;
1182 SvFLAGS(sv) &= ~SVTYPEMASK;
1188 Perl_sv_backoff(pTHX_ register SV *sv)
1192 char *s = SvPVX(sv);
1193 SvLEN(sv) += SvIVX(sv);
1194 SvPVX(sv) -= SvIVX(sv);
1196 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1198 SvFLAGS(sv) &= ~SVf_OOK;
1203 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1207 #ifdef HAS_64K_LIMIT
1208 if (newlen >= 0x10000) {
1209 PerlIO_printf(Perl_debug_log, "Allocation too large: %lx\n", newlen);
1212 #endif /* HAS_64K_LIMIT */
1215 if (SvTYPE(sv) < SVt_PV) {
1216 sv_upgrade(sv, SVt_PV);
1219 else if (SvOOK(sv)) { /* pv is offset? */
1222 if (newlen > SvLEN(sv))
1223 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1224 #ifdef HAS_64K_LIMIT
1225 if (newlen >= 0x10000)
1231 if (newlen > SvLEN(sv)) { /* need more room? */
1232 if (SvLEN(sv) && s) {
1233 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
1234 STRLEN l = malloced_size((void*)SvPVX(sv));
1240 Renew(s,newlen,char);
1243 New(703,s,newlen,char);
1245 SvLEN_set(sv, newlen);
1251 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1253 SV_CHECK_THINKFIRST(sv);
1254 switch (SvTYPE(sv)) {
1256 sv_upgrade(sv, SVt_IV);
1259 sv_upgrade(sv, SVt_PVNV);
1263 sv_upgrade(sv, SVt_PVIV);
1274 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1275 PL_op_desc[PL_op->op_type]);
1278 (void)SvIOK_only(sv); /* validate number */
1284 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1291 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1299 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1306 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1308 SV_CHECK_THINKFIRST(sv);
1309 switch (SvTYPE(sv)) {
1312 sv_upgrade(sv, SVt_NV);
1317 sv_upgrade(sv, SVt_PVNV);
1328 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1329 PL_op_name[PL_op->op_type]);
1333 (void)SvNOK_only(sv); /* validate number */
1338 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1345 S_not_a_number(pTHX_ SV *sv)
1351 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1352 /* each *s can expand to 4 chars + "...\0",
1353 i.e. need room for 8 chars */
1355 for (s = SvPVX(sv); *s && d < limit; s++) {
1357 if (ch & 128 && !isPRINT_LC(ch)) {
1366 else if (ch == '\r') {
1370 else if (ch == '\f') {
1374 else if (ch == '\\') {
1378 else if (isPRINT_LC(ch))
1393 Perl_warner(aTHX_ WARN_NUMERIC,
1394 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1395 PL_op_desc[PL_op->op_type]);
1397 Perl_warner(aTHX_ WARN_NUMERIC,
1398 "Argument \"%s\" isn't numeric", tmpbuf);
1401 /* the number can be converted to integer with atol() or atoll() */
1402 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1403 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1404 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1405 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1407 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1408 until proven guilty, assume that things are not that bad... */
1411 Perl_sv_2iv(pTHX_ register SV *sv)
1415 if (SvGMAGICAL(sv)) {
1420 return I_V(SvNVX(sv));
1422 if (SvPOKp(sv) && SvLEN(sv))
1425 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1427 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1428 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1433 if (SvTHINKFIRST(sv)) {
1436 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1437 return SvIV(tmpstr);
1438 return PTR2IV(SvRV(sv));
1440 if (SvREADONLY(sv) && !SvOK(sv)) {
1442 if (ckWARN(WARN_UNINITIALIZED))
1443 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1449 return (IV)(SvUVX(sv));
1456 /* We can cache the IV/UV value even if it not good enough
1457 * to reconstruct NV, since the conversion to PV will prefer
1461 if (SvTYPE(sv) == SVt_NV)
1462 sv_upgrade(sv, SVt_PVNV);
1465 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1466 SvIVX(sv) = I_V(SvNVX(sv));
1468 SvUVX(sv) = U_V(SvNVX(sv));
1471 DEBUG_c(PerlIO_printf(Perl_debug_log,
1472 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1476 return (IV)SvUVX(sv);
1479 else if (SvPOKp(sv) && SvLEN(sv)) {
1480 I32 numtype = looks_like_number(sv);
1482 /* We want to avoid a possible problem when we cache an IV which
1483 may be later translated to an NV, and the resulting NV is not
1484 the translation of the initial data.
1486 This means that if we cache such an IV, we need to cache the
1487 NV as well. Moreover, we trade speed for space, and do not
1488 cache the NV if not needed.
1490 if (numtype & IS_NUMBER_NOT_IV) {
1491 /* May be not an integer. Need to cache NV if we cache IV
1492 * - otherwise future conversion to NV will be wrong. */
1495 d = Atof(SvPVX(sv));
1497 if (SvTYPE(sv) < SVt_PVNV)
1498 sv_upgrade(sv, SVt_PVNV);
1502 #if defined(USE_LONG_DOUBLE)
1503 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1504 (unsigned long)sv, SvNVX(sv)));
1506 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1507 (unsigned long)sv, SvNVX(sv)));
1509 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1510 SvIVX(sv) = I_V(SvNVX(sv));
1512 SvUVX(sv) = U_V(SvNVX(sv));
1518 /* The NV may be reconstructed from IV - safe to cache IV,
1519 which may be calculated by atol(). */
1520 if (SvTYPE(sv) == SVt_PV)
1521 sv_upgrade(sv, SVt_PVIV);
1523 SvIVX(sv) = Atol(SvPVX(sv));
1525 else { /* Not a number. Cache 0. */
1528 if (SvTYPE(sv) < SVt_PVIV)
1529 sv_upgrade(sv, SVt_PVIV);
1532 if (ckWARN(WARN_NUMERIC))
1538 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1539 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1540 if (SvTYPE(sv) < SVt_IV)
1541 /* Typically the caller expects that sv_any is not NULL now. */
1542 sv_upgrade(sv, SVt_IV);
1545 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%ld)\n",
1546 (unsigned long)sv,(long)SvIVX(sv)));
1547 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1551 Perl_sv_2uv(pTHX_ register SV *sv)
1555 if (SvGMAGICAL(sv)) {
1560 return U_V(SvNVX(sv));
1561 if (SvPOKp(sv) && SvLEN(sv))
1564 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1566 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1567 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1572 if (SvTHINKFIRST(sv)) {
1575 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1576 return SvUV(tmpstr);
1577 return PTR2UV(SvRV(sv));
1579 if (SvREADONLY(sv) && !SvOK(sv)) {
1581 if (ckWARN(WARN_UNINITIALIZED))
1582 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1591 return (UV)SvIVX(sv);
1595 /* We can cache the IV/UV value even if it not good enough
1596 * to reconstruct NV, since the conversion to PV will prefer
1599 if (SvTYPE(sv) == SVt_NV)
1600 sv_upgrade(sv, SVt_PVNV);
1602 if (SvNVX(sv) >= -0.5) {
1604 SvUVX(sv) = U_V(SvNVX(sv));
1607 SvIVX(sv) = I_V(SvNVX(sv));
1609 DEBUG_c(PerlIO_printf(Perl_debug_log,
1610 "0x%"UVxf" 2uv(%"IVdf" => %"UVdf") (as signed)\n",
1613 (IV)(UV)SvIVX(sv)));
1614 return (UV)SvIVX(sv);
1617 else if (SvPOKp(sv) && SvLEN(sv)) {
1618 I32 numtype = looks_like_number(sv);
1620 /* We want to avoid a possible problem when we cache a UV which
1621 may be later translated to an NV, and the resulting NV is not
1622 the translation of the initial data.
1624 This means that if we cache such a UV, we need to cache the
1625 NV as well. Moreover, we trade speed for space, and do not
1626 cache the NV if not needed.
1628 if (numtype & IS_NUMBER_NOT_IV) {
1629 /* May be not an integer. Need to cache NV if we cache IV
1630 * - otherwise future conversion to NV will be wrong. */
1633 d = Atof(SvPVX(sv));
1635 if (SvTYPE(sv) < SVt_PVNV)
1636 sv_upgrade(sv, SVt_PVNV);
1640 #if defined(USE_LONG_DOUBLE)
1641 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1642 (unsigned long)sv, SvNVX(sv)));
1644 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n",
1645 (unsigned long)sv, SvNVX(sv)));
1647 if (SvNVX(sv) < -0.5) {
1648 SvIVX(sv) = I_V(SvNVX(sv));
1651 SvUVX(sv) = U_V(SvNVX(sv));
1655 else if (numtype & IS_NUMBER_NEG) {
1656 /* The NV may be reconstructed from IV - safe to cache IV,
1657 which may be calculated by atol(). */
1658 if (SvTYPE(sv) == SVt_PV)
1659 sv_upgrade(sv, SVt_PVIV);
1661 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1663 else if (numtype) { /* Non-negative */
1664 /* The NV may be reconstructed from UV - safe to cache UV,
1665 which may be calculated by strtoul()/atol. */
1666 if (SvTYPE(sv) == SVt_PV)
1667 sv_upgrade(sv, SVt_PVIV);
1669 (void)SvIsUV_on(sv);
1671 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1672 #else /* no atou(), but we know the number fits into IV... */
1673 /* The only problem may be if it is negative... */
1674 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1677 else { /* Not a number. Cache 0. */
1680 if (SvTYPE(sv) < SVt_PVIV)
1681 sv_upgrade(sv, SVt_PVIV);
1682 SvUVX(sv) = 0; /* We assume that 0s have the
1683 same bitmap in IV and UV. */
1685 (void)SvIsUV_on(sv);
1686 if (ckWARN(WARN_NUMERIC))
1691 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1693 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1694 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1696 if (SvTYPE(sv) < SVt_IV)
1697 /* Typically the caller expects that sv_any is not NULL now. */
1698 sv_upgrade(sv, SVt_IV);
1702 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%lu)\n",
1703 (unsigned long)sv,SvUVX(sv)));
1704 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1708 Perl_sv_2nv(pTHX_ register SV *sv)
1712 if (SvGMAGICAL(sv)) {
1716 if (SvPOKp(sv) && SvLEN(sv)) {
1718 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1720 return Atof(SvPVX(sv));
1724 return (NV)SvUVX(sv);
1726 return (NV)SvIVX(sv);
1729 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1731 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1732 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1737 if (SvTHINKFIRST(sv)) {
1740 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1741 return SvNV(tmpstr);
1742 return PTR2NV(SvRV(sv));
1744 if (SvREADONLY(sv) && !SvOK(sv)) {
1746 if (ckWARN(WARN_UNINITIALIZED))
1747 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1751 if (SvTYPE(sv) < SVt_NV) {
1752 if (SvTYPE(sv) == SVt_IV)
1753 sv_upgrade(sv, SVt_PVNV);
1755 sv_upgrade(sv, SVt_NV);
1756 #if defined(USE_LONG_DOUBLE)
1758 RESTORE_NUMERIC_STANDARD();
1759 PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIgldbl ")\n",
1760 (unsigned long)sv, SvNVX(sv));
1761 RESTORE_NUMERIC_LOCAL();
1765 RESTORE_NUMERIC_STANDARD();
1766 PerlIO_printf(Perl_debug_log, "0x%lx num(%g)\n",
1767 (unsigned long)sv, SvNVX(sv));
1768 RESTORE_NUMERIC_LOCAL();
1772 else if (SvTYPE(sv) < SVt_PVNV)
1773 sv_upgrade(sv, SVt_PVNV);
1775 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1777 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1779 else if (SvPOKp(sv) && SvLEN(sv)) {
1781 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1783 SvNVX(sv) = Atof(SvPVX(sv));
1787 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1788 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1789 if (SvTYPE(sv) < SVt_NV)
1790 /* Typically the caller expects that sv_any is not NULL now. */
1791 sv_upgrade(sv, SVt_NV);
1795 #if defined(USE_LONG_DOUBLE)
1797 RESTORE_NUMERIC_STANDARD();
1798 PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n",
1799 (unsigned long)sv, SvNVX(sv));
1800 RESTORE_NUMERIC_LOCAL();
1804 RESTORE_NUMERIC_STANDARD();
1805 PerlIO_printf(Perl_debug_log, "0x%lx 1nv(%g)\n",
1806 (unsigned long)sv, SvNVX(sv));
1807 RESTORE_NUMERIC_LOCAL();
1814 S_asIV(pTHX_ SV *sv)
1816 I32 numtype = looks_like_number(sv);
1819 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1820 return Atol(SvPVX(sv));
1823 if (ckWARN(WARN_NUMERIC))
1826 d = Atof(SvPVX(sv));
1831 S_asUV(pTHX_ SV *sv)
1833 I32 numtype = looks_like_number(sv);
1836 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1837 return Strtoul(SvPVX(sv), Null(char**), 10);
1841 if (ckWARN(WARN_NUMERIC))
1844 return U_V(Atof(SvPVX(sv)));
1848 * Returns a combination of (advisory only - can get false negatives)
1849 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1851 * 0 if does not look like number.
1853 * In fact possible values are 0 and
1854 * IS_NUMBER_TO_INT_BY_ATOL 123
1855 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1856 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1857 * with a possible addition of IS_NUMBER_NEG.
1861 Perl_looks_like_number(pTHX_ SV *sv)
1864 register char *send;
1865 register char *sbegin;
1866 register char *nbegin;
1874 else if (SvPOKp(sv))
1875 sbegin = SvPV(sv, len);
1878 send = sbegin + len;
1885 numtype = IS_NUMBER_NEG;
1892 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1893 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1897 /* next must be digit or the radix separator */
1901 } while (isDIGIT(*s));
1903 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1904 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1906 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1909 #ifdef USE_LOCALE_NUMERIC
1910 || IS_NUMERIC_RADIX(*s)
1914 numtype |= IS_NUMBER_NOT_IV;
1915 while (isDIGIT(*s)) /* optional digits after the radix */
1920 #ifdef USE_LOCALE_NUMERIC
1921 || IS_NUMERIC_RADIX(*s)
1925 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1926 /* no digits before the radix means we need digits after it */
1930 } while (isDIGIT(*s));
1938 /* we can have an optional exponent part */
1939 if (*s == 'e' || *s == 'E') {
1940 numtype &= ~IS_NUMBER_NEG;
1941 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1943 if (*s == '+' || *s == '-')
1948 } while (isDIGIT(*s));
1957 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1958 return IS_NUMBER_TO_INT_BY_ATOL;
1963 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1966 return sv_2pv(sv, &n_a);
1969 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1971 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1974 char *ptr = buf + TYPE_CHARS(UV);
1989 *--ptr = '0' + (uv % 10);
1998 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2003 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2004 char *tmpbuf = tbuf;
2010 if (SvGMAGICAL(sv)) {
2018 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2020 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2025 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2030 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2032 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2033 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
2039 if (SvTHINKFIRST(sv)) {
2042 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2043 return SvPV(tmpstr,*lp);
2050 switch (SvTYPE(sv)) {
2052 if ( ((SvFLAGS(sv) &
2053 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2054 == (SVs_OBJECT|SVs_RMG))
2055 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2056 && (mg = mg_find(sv, 'r'))) {
2058 regexp *re = (regexp *)mg->mg_obj;
2061 char *fptr = "msix";
2066 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2068 while(ch = *fptr++) {
2070 reflags[left++] = ch;
2073 reflags[right--] = ch;
2078 reflags[left] = '-';
2082 mg->mg_len = re->prelen + 4 + left;
2083 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2084 Copy("(?", mg->mg_ptr, 2, char);
2085 Copy(reflags, mg->mg_ptr+2, left, char);
2086 Copy(":", mg->mg_ptr+left+2, 1, char);
2087 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2088 mg->mg_ptr[mg->mg_len - 1] = ')';
2089 mg->mg_ptr[mg->mg_len] = 0;
2091 PL_reginterp_cnt += re->program[0].next_off;
2103 case SVt_PVBM: s = "SCALAR"; break;
2104 case SVt_PVLV: s = "LVALUE"; break;
2105 case SVt_PVAV: s = "ARRAY"; break;
2106 case SVt_PVHV: s = "HASH"; break;
2107 case SVt_PVCV: s = "CODE"; break;
2108 case SVt_PVGV: s = "GLOB"; break;
2109 case SVt_PVFM: s = "FORMAT"; break;
2110 case SVt_PVIO: s = "IO"; break;
2111 default: s = "UNKNOWN"; break;
2115 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2118 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2124 if (SvREADONLY(sv) && !SvOK(sv)) {
2126 if (ckWARN(WARN_UNINITIALIZED))
2127 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
2132 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2133 /* XXXX 64-bit? IV may have better precision... */
2134 /* I tried changing this for to be 64-bit-aware and
2135 * the t/op/numconvert.t became very, very, angry.
2137 if (SvTYPE(sv) < SVt_PVNV)
2138 sv_upgrade(sv, SVt_PVNV);
2141 olderrno = errno; /* some Xenix systems wipe out errno here */
2143 if (SvNVX(sv) == 0.0)
2144 (void)strcpy(s,"0");
2148 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2151 #ifdef FIXNEGATIVEZERO
2152 if (*s == '-' && s[1] == '0' && !s[2])
2161 else if (SvIOKp(sv)) {
2162 U32 isIOK = SvIOK(sv);
2163 U32 isUIOK = SvIsUV(sv);
2164 char buf[TYPE_CHARS(UV)];
2167 if (SvTYPE(sv) < SVt_PVIV)
2168 sv_upgrade(sv, SVt_PVIV);
2170 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2172 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2173 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2174 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2175 SvCUR_set(sv, ebuf - ptr);
2188 if (ckWARN(WARN_UNINITIALIZED)
2189 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2191 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
2194 if (SvTYPE(sv) < SVt_PV)
2195 /* Typically the caller expects that sv_any is not NULL now. */
2196 sv_upgrade(sv, SVt_PV);
2199 *lp = s - SvPVX(sv);
2202 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
2203 (unsigned long)sv,SvPVX(sv)));
2207 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2208 /* Sneaky stuff here */
2212 tsv = newSVpv(tmpbuf, 0);
2228 len = strlen(tmpbuf);
2230 #ifdef FIXNEGATIVEZERO
2231 if (len == 2 && t[0] == '-' && t[1] == '0') {
2236 (void)SvUPGRADE(sv, SVt_PV);
2238 s = SvGROW(sv, len + 1);
2246 /* This function is only called on magical items */
2248 Perl_sv_2bool(pTHX_ register SV *sv)
2258 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2259 return SvTRUE(tmpsv);
2260 return SvRV(sv) != 0;
2263 register XPV* Xpvtmp;
2264 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2265 (*Xpvtmp->xpv_pv > '0' ||
2266 Xpvtmp->xpv_cur > 1 ||
2267 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2274 return SvIVX(sv) != 0;
2277 return SvNVX(sv) != 0.0;
2284 /* Note: sv_setsv() should not be called with a source string that needs
2285 * to be reused, since it may destroy the source string if it is marked
2290 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2293 register U32 sflags;
2299 SV_CHECK_THINKFIRST(dstr);
2301 sstr = &PL_sv_undef;
2302 stype = SvTYPE(sstr);
2303 dtype = SvTYPE(dstr);
2307 /* There's a lot of redundancy below but we're going for speed here */
2312 if (dtype != SVt_PVGV) {
2313 (void)SvOK_off(dstr);
2321 sv_upgrade(dstr, SVt_IV);
2324 sv_upgrade(dstr, SVt_PVNV);
2328 sv_upgrade(dstr, SVt_PVIV);
2331 (void)SvIOK_only(dstr);
2332 SvIVX(dstr) = SvIVX(sstr);
2345 sv_upgrade(dstr, SVt_NV);
2350 sv_upgrade(dstr, SVt_PVNV);
2353 SvNVX(dstr) = SvNVX(sstr);
2354 (void)SvNOK_only(dstr);
2362 sv_upgrade(dstr, SVt_RV);
2363 else if (dtype == SVt_PVGV &&
2364 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2367 if (PL_curcop->cop_stash != GvSTASH(dstr))
2368 GvIMPORTED_on(dstr);
2378 sv_upgrade(dstr, SVt_PV);
2381 if (dtype < SVt_PVIV)
2382 sv_upgrade(dstr, SVt_PVIV);
2385 if (dtype < SVt_PVNV)
2386 sv_upgrade(dstr, SVt_PVNV);
2393 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2394 PL_op_name[PL_op->op_type]);
2396 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2400 if (dtype <= SVt_PVGV) {
2402 if (dtype != SVt_PVGV) {
2403 char *name = GvNAME(sstr);
2404 STRLEN len = GvNAMELEN(sstr);
2405 sv_upgrade(dstr, SVt_PVGV);
2406 sv_magic(dstr, dstr, '*', name, len);
2407 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2408 GvNAME(dstr) = savepvn(name, len);
2409 GvNAMELEN(dstr) = len;
2410 SvFAKE_on(dstr); /* can coerce to non-glob */
2412 /* ahem, death to those who redefine active sort subs */
2413 else if (PL_curstackinfo->si_type == PERLSI_SORT
2414 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2415 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2417 (void)SvOK_off(dstr);
2418 GvINTRO_off(dstr); /* one-shot flag */
2420 GvGP(dstr) = gp_ref(GvGP(sstr));
2422 if (PL_curcop->cop_stash != GvSTASH(dstr))
2423 GvIMPORTED_on(dstr);
2430 if (SvGMAGICAL(sstr)) {
2432 if (SvTYPE(sstr) != stype) {
2433 stype = SvTYPE(sstr);
2434 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2438 if (stype == SVt_PVLV)
2439 (void)SvUPGRADE(dstr, SVt_PVNV);
2441 (void)SvUPGRADE(dstr, stype);
2444 sflags = SvFLAGS(sstr);
2446 if (sflags & SVf_ROK) {
2447 if (dtype >= SVt_PV) {
2448 if (dtype == SVt_PVGV) {
2449 SV *sref = SvREFCNT_inc(SvRV(sstr));
2451 int intro = GvINTRO(dstr);
2455 GvGP(dstr)->gp_refcnt--;
2456 GvINTRO_off(dstr); /* one-shot flag */
2457 Newz(602,gp, 1, GP);
2458 GvGP(dstr) = gp_ref(gp);
2459 GvSV(dstr) = NEWSV(72,0);
2460 GvLINE(dstr) = PL_curcop->cop_line;
2461 GvEGV(dstr) = (GV*)dstr;
2464 switch (SvTYPE(sref)) {
2467 SAVESPTR(GvAV(dstr));
2469 dref = (SV*)GvAV(dstr);
2470 GvAV(dstr) = (AV*)sref;
2471 if (PL_curcop->cop_stash != GvSTASH(dstr))
2472 GvIMPORTED_AV_on(dstr);
2476 SAVESPTR(GvHV(dstr));
2478 dref = (SV*)GvHV(dstr);
2479 GvHV(dstr) = (HV*)sref;
2480 if (PL_curcop->cop_stash != GvSTASH(dstr))
2481 GvIMPORTED_HV_on(dstr);
2485 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2486 SvREFCNT_dec(GvCV(dstr));
2487 GvCV(dstr) = Nullcv;
2488 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2489 PL_sub_generation++;
2491 SAVESPTR(GvCV(dstr));
2494 dref = (SV*)GvCV(dstr);
2495 if (GvCV(dstr) != (CV*)sref) {
2496 CV* cv = GvCV(dstr);
2498 if (!GvCVGEN((GV*)dstr) &&
2499 (CvROOT(cv) || CvXSUB(cv)))
2501 SV *const_sv = cv_const_sv(cv);
2502 bool const_changed = TRUE;
2504 const_changed = sv_cmp(const_sv,
2505 op_const_sv(CvSTART((CV*)sref),
2507 /* ahem, death to those who redefine
2508 * active sort subs */
2509 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2510 PL_sortcop == CvSTART(cv))
2512 "Can't redefine active sort subroutine %s",
2513 GvENAME((GV*)dstr));
2514 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2515 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2516 && HvNAME(GvSTASH(CvGV(cv)))
2517 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2519 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2520 "Constant subroutine %s redefined"
2521 : "Subroutine %s redefined",
2522 GvENAME((GV*)dstr));
2525 cv_ckproto(cv, (GV*)dstr,
2526 SvPOK(sref) ? SvPVX(sref) : Nullch);
2528 GvCV(dstr) = (CV*)sref;
2529 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2530 GvASSUMECV_on(dstr);
2531 PL_sub_generation++;
2533 if (PL_curcop->cop_stash != GvSTASH(dstr))
2534 GvIMPORTED_CV_on(dstr);
2538 SAVESPTR(GvIOp(dstr));
2540 dref = (SV*)GvIOp(dstr);
2541 GvIOp(dstr) = (IO*)sref;
2545 SAVESPTR(GvSV(dstr));
2547 dref = (SV*)GvSV(dstr);
2549 if (PL_curcop->cop_stash != GvSTASH(dstr))
2550 GvIMPORTED_SV_on(dstr);
2561 (void)SvOOK_off(dstr); /* backoff */
2563 Safefree(SvPVX(dstr));
2564 SvLEN(dstr)=SvCUR(dstr)=0;
2567 (void)SvOK_off(dstr);
2568 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2570 if (sflags & SVp_NOK) {
2572 SvNVX(dstr) = SvNVX(sstr);
2574 if (sflags & SVp_IOK) {
2575 (void)SvIOK_on(dstr);
2576 SvIVX(dstr) = SvIVX(sstr);
2580 if (SvAMAGIC(sstr)) {
2584 else if (sflags & SVp_POK) {
2587 * Check to see if we can just swipe the string. If so, it's a
2588 * possible small lose on short strings, but a big win on long ones.
2589 * It might even be a win on short strings if SvPVX(dstr)
2590 * has to be allocated and SvPVX(sstr) has to be freed.
2593 if (SvTEMP(sstr) && /* slated for free anyway? */
2594 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2595 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2597 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2599 SvFLAGS(dstr) &= ~SVf_OOK;
2600 Safefree(SvPVX(dstr) - SvIVX(dstr));
2602 else if (SvLEN(dstr))
2603 Safefree(SvPVX(dstr));
2605 (void)SvPOK_only(dstr);
2606 SvPV_set(dstr, SvPVX(sstr));
2607 SvLEN_set(dstr, SvLEN(sstr));
2608 SvCUR_set(dstr, SvCUR(sstr));
2610 (void)SvOK_off(sstr);
2611 SvPV_set(sstr, Nullch);
2616 else { /* have to copy actual string */
2617 STRLEN len = SvCUR(sstr);
2619 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2620 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2621 SvCUR_set(dstr, len);
2622 *SvEND(dstr) = '\0';
2623 (void)SvPOK_only(dstr);
2626 if (sflags & SVp_NOK) {
2628 SvNVX(dstr) = SvNVX(sstr);
2630 if (sflags & SVp_IOK) {
2631 (void)SvIOK_on(dstr);
2632 SvIVX(dstr) = SvIVX(sstr);
2637 else if (sflags & SVp_NOK) {
2638 SvNVX(dstr) = SvNVX(sstr);
2639 (void)SvNOK_only(dstr);
2641 (void)SvIOK_on(dstr);
2642 SvIVX(dstr) = SvIVX(sstr);
2643 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2648 else if (sflags & SVp_IOK) {
2649 (void)SvIOK_only(dstr);
2650 SvIVX(dstr) = SvIVX(sstr);
2655 if (dtype == SVt_PVGV) {
2656 if (ckWARN(WARN_UNSAFE))
2657 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2660 (void)SvOK_off(dstr);
2666 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2668 sv_setsv(dstr,sstr);
2673 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2675 register char *dptr;
2676 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2677 elicit a warning, but it won't hurt. */
2678 SV_CHECK_THINKFIRST(sv);
2683 (void)SvUPGRADE(sv, SVt_PV);
2685 SvGROW(sv, len + 1);
2687 Move(ptr,dptr,len,char);
2690 (void)SvPOK_only(sv); /* validate pointer */
2695 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2697 sv_setpvn(sv,ptr,len);
2702 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2704 register STRLEN len;
2706 SV_CHECK_THINKFIRST(sv);
2712 (void)SvUPGRADE(sv, SVt_PV);
2714 SvGROW(sv, len + 1);
2715 Move(ptr,SvPVX(sv),len+1,char);
2717 (void)SvPOK_only(sv); /* validate pointer */
2722 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2729 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2731 SV_CHECK_THINKFIRST(sv);
2732 (void)SvUPGRADE(sv, SVt_PV);
2737 (void)SvOOK_off(sv);
2738 if (SvPVX(sv) && SvLEN(sv))
2739 Safefree(SvPVX(sv));
2740 Renew(ptr, len+1, char);
2743 SvLEN_set(sv, len+1);
2745 (void)SvPOK_only(sv); /* validate pointer */
2750 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2752 sv_usepvn(sv,ptr,len);
2757 Perl_sv_force_normal(pTHX_ register SV *sv)
2759 if (SvREADONLY(sv)) {
2761 if (PL_curcop != &PL_compiling)
2762 Perl_croak(aTHX_ PL_no_modify);
2766 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2771 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2775 register STRLEN delta;
2777 if (!ptr || !SvPOKp(sv))
2779 SV_CHECK_THINKFIRST(sv);
2780 if (SvTYPE(sv) < SVt_PVIV)
2781 sv_upgrade(sv,SVt_PVIV);
2784 if (!SvLEN(sv)) { /* make copy of shared string */
2785 char *pvx = SvPVX(sv);
2786 STRLEN len = SvCUR(sv);
2787 SvGROW(sv, len + 1);
2788 Move(pvx,SvPVX(sv),len,char);
2792 SvFLAGS(sv) |= SVf_OOK;
2794 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2795 delta = ptr - SvPVX(sv);
2803 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2808 junk = SvPV_force(sv, tlen);
2809 SvGROW(sv, tlen + len + 1);
2812 Move(ptr,SvPVX(sv)+tlen,len,char);
2815 (void)SvPOK_only(sv); /* validate pointer */
2820 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2822 sv_catpvn(sv,ptr,len);
2827 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2833 if (s = SvPV(sstr, len))
2834 sv_catpvn(dstr,s,len);
2838 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2840 sv_catsv(dstr,sstr);
2845 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2847 register STRLEN len;
2853 junk = SvPV_force(sv, tlen);
2855 SvGROW(sv, tlen + len + 1);
2858 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2860 (void)SvPOK_only(sv); /* validate pointer */
2865 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2872 Perl_newSV(pTHX_ STRLEN len)
2878 sv_upgrade(sv, SVt_PV);
2879 SvGROW(sv, len + 1);
2884 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2887 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2891 if (SvREADONLY(sv)) {
2893 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2894 Perl_croak(aTHX_ PL_no_modify);
2896 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2897 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2904 (void)SvUPGRADE(sv, SVt_PVMG);
2906 Newz(702,mg, 1, MAGIC);
2907 mg->mg_moremagic = SvMAGIC(sv);
2910 if (!obj || obj == sv || how == '#' || how == 'r')
2914 mg->mg_obj = SvREFCNT_inc(obj);
2915 mg->mg_flags |= MGf_REFCOUNTED;
2918 mg->mg_len = namlen;
2921 mg->mg_ptr = savepvn(name, namlen);
2922 else if (namlen == HEf_SVKEY)
2923 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2927 mg->mg_virtual = &PL_vtbl_sv;
2930 mg->mg_virtual = &PL_vtbl_amagic;
2933 mg->mg_virtual = &PL_vtbl_amagicelem;
2939 mg->mg_virtual = &PL_vtbl_bm;
2942 mg->mg_virtual = &PL_vtbl_regdata;
2945 mg->mg_virtual = &PL_vtbl_regdatum;
2948 mg->mg_virtual = &PL_vtbl_env;
2951 mg->mg_virtual = &PL_vtbl_fm;
2954 mg->mg_virtual = &PL_vtbl_envelem;
2957 mg->mg_virtual = &PL_vtbl_mglob;
2960 mg->mg_virtual = &PL_vtbl_isa;
2963 mg->mg_virtual = &PL_vtbl_isaelem;
2966 mg->mg_virtual = &PL_vtbl_nkeys;
2973 mg->mg_virtual = &PL_vtbl_dbline;
2977 mg->mg_virtual = &PL_vtbl_mutex;
2979 #endif /* USE_THREADS */
2980 #ifdef USE_LOCALE_COLLATE
2982 mg->mg_virtual = &PL_vtbl_collxfrm;
2984 #endif /* USE_LOCALE_COLLATE */
2986 mg->mg_virtual = &PL_vtbl_pack;
2990 mg->mg_virtual = &PL_vtbl_packelem;
2993 mg->mg_virtual = &PL_vtbl_regexp;
2996 mg->mg_virtual = &PL_vtbl_sig;
2999 mg->mg_virtual = &PL_vtbl_sigelem;
3002 mg->mg_virtual = &PL_vtbl_taint;
3006 mg->mg_virtual = &PL_vtbl_uvar;
3009 mg->mg_virtual = &PL_vtbl_vec;
3012 mg->mg_virtual = &PL_vtbl_substr;
3015 mg->mg_virtual = &PL_vtbl_defelem;
3018 mg->mg_virtual = &PL_vtbl_glob;
3021 mg->mg_virtual = &PL_vtbl_arylen;
3024 mg->mg_virtual = &PL_vtbl_pos;
3027 mg->mg_virtual = &PL_vtbl_backref;
3029 case '~': /* Reserved for use by extensions not perl internals. */
3030 /* Useful for attaching extension internal data to perl vars. */
3031 /* Note that multiple extensions may clash if magical scalars */
3032 /* etc holding private data from one are passed to another. */
3036 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3040 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3044 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3048 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3051 for (mg = *mgp; mg; mg = *mgp) {
3052 if (mg->mg_type == type) {
3053 MGVTBL* vtbl = mg->mg_virtual;
3054 *mgp = mg->mg_moremagic;
3055 if (vtbl && (vtbl->svt_free != NULL))
3056 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3057 if (mg->mg_ptr && mg->mg_type != 'g')
3058 if (mg->mg_len >= 0)
3059 Safefree(mg->mg_ptr);
3060 else if (mg->mg_len == HEf_SVKEY)
3061 SvREFCNT_dec((SV*)mg->mg_ptr);
3062 if (mg->mg_flags & MGf_REFCOUNTED)
3063 SvREFCNT_dec(mg->mg_obj);
3067 mgp = &mg->mg_moremagic;
3071 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3078 Perl_sv_rvweaken(pTHX_ SV *sv)
3081 if (!SvOK(sv)) /* let undefs pass */
3084 Perl_croak(aTHX_ "Can't weaken a nonreference");
3085 else if (SvWEAKREF(sv)) {
3087 if (ckWARN(WARN_MISC))
3088 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3092 sv_add_backref(tsv, sv);
3099 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3103 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3104 av = (AV*)mg->mg_obj;
3107 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3108 SvREFCNT_dec(av); /* for sv_magic */
3114 S_sv_del_backref(pTHX_ SV *sv)
3121 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3122 Perl_croak(aTHX_ "panic: del_backref");
3123 av = (AV *)mg->mg_obj;
3128 svp[i] = &PL_sv_undef; /* XXX */
3135 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3139 register char *midend;
3140 register char *bigend;
3146 Perl_croak(aTHX_ "Can't modify non-existent substring");
3147 SvPV_force(bigstr, curlen);
3148 if (offset + len > curlen) {
3149 SvGROW(bigstr, offset+len+1);
3150 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3151 SvCUR_set(bigstr, offset+len);
3154 i = littlelen - len;
3155 if (i > 0) { /* string might grow */
3156 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3157 mid = big + offset + len;
3158 midend = bigend = big + SvCUR(bigstr);
3161 while (midend > mid) /* shove everything down */
3162 *--bigend = *--midend;
3163 Move(little,big+offset,littlelen,char);
3169 Move(little,SvPVX(bigstr)+offset,len,char);
3174 big = SvPVX(bigstr);
3177 bigend = big + SvCUR(bigstr);
3179 if (midend > bigend)
3180 Perl_croak(aTHX_ "panic: sv_insert");
3182 if (mid - big > bigend - midend) { /* faster to shorten from end */
3184 Move(little, mid, littlelen,char);
3187 i = bigend - midend;
3189 Move(midend, mid, i,char);
3193 SvCUR_set(bigstr, mid - big);
3196 else if (i = mid - big) { /* faster from front */
3197 midend -= littlelen;
3199 sv_chop(bigstr,midend-i);
3204 Move(little, mid, littlelen,char);
3206 else if (littlelen) {
3207 midend -= littlelen;
3208 sv_chop(bigstr,midend);
3209 Move(little,midend,littlelen,char);
3212 sv_chop(bigstr,midend);
3217 /* make sv point to what nstr did */
3220 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3223 U32 refcnt = SvREFCNT(sv);
3224 SV_CHECK_THINKFIRST(sv);
3225 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3226 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3227 if (SvMAGICAL(sv)) {
3231 sv_upgrade(nsv, SVt_PVMG);
3232 SvMAGIC(nsv) = SvMAGIC(sv);
3233 SvFLAGS(nsv) |= SvMAGICAL(sv);
3239 assert(!SvREFCNT(sv));
3240 StructCopy(nsv,sv,SV);
3241 SvREFCNT(sv) = refcnt;
3242 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3247 Perl_sv_clear(pTHX_ register SV *sv)
3251 assert(SvREFCNT(sv) == 0);
3255 if (PL_defstash) { /* Still have a symbol table? */
3260 Zero(&tmpref, 1, SV);
3261 sv_upgrade(&tmpref, SVt_RV);
3263 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3264 SvREFCNT(&tmpref) = 1;
3267 stash = SvSTASH(sv);
3268 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3271 PUSHSTACKi(PERLSI_DESTROY);
3272 SvRV(&tmpref) = SvREFCNT_inc(sv);
3277 call_sv((SV*)GvCV(destructor),
3278 G_DISCARD|G_EVAL|G_KEEPERR);
3284 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3286 del_XRV(SvANY(&tmpref));
3289 if (PL_in_clean_objs)
3290 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3292 /* DESTROY gave object new lease on life */
3298 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3299 SvOBJECT_off(sv); /* Curse the object. */
3300 if (SvTYPE(sv) != SVt_PVIO)
3301 --PL_sv_objcount; /* XXX Might want something more general */
3304 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3307 switch (SvTYPE(sv)) {
3310 IoIFP(sv) != PerlIO_stdin() &&
3311 IoIFP(sv) != PerlIO_stdout() &&
3312 IoIFP(sv) != PerlIO_stderr())
3314 io_close((IO*)sv, FALSE);
3317 PerlDir_close(IoDIRP(sv));
3320 Safefree(IoTOP_NAME(sv));
3321 Safefree(IoFMT_NAME(sv));
3322 Safefree(IoBOTTOM_NAME(sv));
3337 SvREFCNT_dec(LvTARG(sv));
3341 Safefree(GvNAME(sv));
3342 /* cannot decrease stash refcount yet, as we might recursively delete
3343 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3344 of stash until current sv is completely gone.
3345 -- JohnPC, 27 Mar 1998 */
3346 stash = GvSTASH(sv);
3352 (void)SvOOK_off(sv);
3360 SvREFCNT_dec(SvRV(sv));
3362 else if (SvPVX(sv) && SvLEN(sv))
3363 Safefree(SvPVX(sv));
3373 switch (SvTYPE(sv)) {
3389 del_XPVIV(SvANY(sv));
3392 del_XPVNV(SvANY(sv));
3395 del_XPVMG(SvANY(sv));
3398 del_XPVLV(SvANY(sv));
3401 del_XPVAV(SvANY(sv));
3404 del_XPVHV(SvANY(sv));
3407 del_XPVCV(SvANY(sv));
3410 del_XPVGV(SvANY(sv));
3411 /* code duplication for increased performance. */
3412 SvFLAGS(sv) &= SVf_BREAK;
3413 SvFLAGS(sv) |= SVTYPEMASK;
3414 /* decrease refcount of the stash that owns this GV, if any */
3416 SvREFCNT_dec(stash);
3417 return; /* not break, SvFLAGS reset already happened */
3419 del_XPVBM(SvANY(sv));
3422 del_XPVFM(SvANY(sv));
3425 del_XPVIO(SvANY(sv));
3428 SvFLAGS(sv) &= SVf_BREAK;
3429 SvFLAGS(sv) |= SVTYPEMASK;
3433 Perl_sv_newref(pTHX_ SV *sv)
3436 ATOMIC_INC(SvREFCNT(sv));
3441 Perl_sv_free(pTHX_ SV *sv)
3444 int refcount_is_zero;
3448 if (SvREFCNT(sv) == 0) {
3449 if (SvFLAGS(sv) & SVf_BREAK)
3451 if (PL_in_clean_all) /* All is fair */
3453 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3454 /* make sure SvREFCNT(sv)==0 happens very seldom */
3455 SvREFCNT(sv) = (~(U32)0)/2;
3458 if (ckWARN_d(WARN_INTERNAL))
3459 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3462 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3463 if (!refcount_is_zero)
3467 if (ckWARN_d(WARN_DEBUGGING))
3468 Perl_warner(aTHX_ WARN_DEBUGGING,
3469 "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv);
3473 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3474 /* make sure SvREFCNT(sv)==0 happens very seldom */
3475 SvREFCNT(sv) = (~(U32)0)/2;
3484 Perl_sv_len(pTHX_ register SV *sv)
3493 len = mg_length(sv);
3495 junk = SvPV(sv, len);
3500 Perl_sv_len_utf8(pTHX_ register SV *sv)
3511 len = mg_length(sv);
3514 s = (U8*)SvPV(sv, len);
3525 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3530 I32 uoffset = *offsetp;
3536 start = s = (U8*)SvPV(sv, len);
3538 while (s < send && uoffset--)
3542 *offsetp = s - start;
3546 while (s < send && ulen--)
3556 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3565 s = (U8*)SvPV(sv, len);
3567 Perl_croak(aTHX_ "panic: bad byte offset");
3568 send = s + *offsetp;
3576 if (ckWARN_d(WARN_UTF8))
3577 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3585 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3597 pv1 = SvPV(str1, cur1);
3602 pv2 = SvPV(str2, cur2);
3607 return memEQ(pv1, pv2, cur1);
3611 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3614 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3616 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3620 return cur2 ? -1 : 0;
3625 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3628 return retval < 0 ? -1 : 1;
3633 return cur1 < cur2 ? -1 : 1;
3637 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3639 #ifdef USE_LOCALE_COLLATE
3645 if (PL_collation_standard)
3649 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3651 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3653 if (!pv1 || !len1) {
3664 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3667 return retval < 0 ? -1 : 1;
3670 * When the result of collation is equality, that doesn't mean
3671 * that there are no differences -- some locales exclude some
3672 * characters from consideration. So to avoid false equalities,
3673 * we use the raw string as a tiebreaker.
3679 #endif /* USE_LOCALE_COLLATE */
3681 return sv_cmp(sv1, sv2);
3684 #ifdef USE_LOCALE_COLLATE
3686 * Any scalar variable may carry an 'o' magic that contains the
3687 * scalar data of the variable transformed to such a format that
3688 * a normal memory comparison can be used to compare the data
3689 * according to the locale settings.
3692 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3696 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3697 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3702 Safefree(mg->mg_ptr);
3704 if ((xf = mem_collxfrm(s, len, &xlen))) {
3705 if (SvREADONLY(sv)) {
3708 return xf + sizeof(PL_collation_ix);
3711 sv_magic(sv, 0, 'o', 0, 0);
3712 mg = mg_find(sv, 'o');
3725 if (mg && mg->mg_ptr) {
3727 return mg->mg_ptr + sizeof(PL_collation_ix);
3735 #endif /* USE_LOCALE_COLLATE */
3738 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3743 register STDCHAR rslast;
3744 register STDCHAR *bp;
3748 SV_CHECK_THINKFIRST(sv);
3749 (void)SvUPGRADE(sv, SVt_PV);
3753 if (RsSNARF(PL_rs)) {
3757 else if (RsRECORD(PL_rs)) {
3758 I32 recsize, bytesread;
3761 /* Grab the size of the record we're getting */
3762 recsize = SvIV(SvRV(PL_rs));
3763 (void)SvPOK_only(sv); /* Validate pointer */
3764 buffer = SvGROW(sv, recsize + 1);
3767 /* VMS wants read instead of fread, because fread doesn't respect */
3768 /* RMS record boundaries. This is not necessarily a good thing to be */
3769 /* doing, but we've got no other real choice */
3770 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3772 bytesread = PerlIO_read(fp, buffer, recsize);
3774 SvCUR_set(sv, bytesread);
3775 buffer[bytesread] = '\0';
3776 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3778 else if (RsPARA(PL_rs)) {
3783 rsptr = SvPV(PL_rs, rslen);
3784 rslast = rslen ? rsptr[rslen - 1] : '\0';
3786 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3787 do { /* to make sure file boundaries work right */
3790 i = PerlIO_getc(fp);
3794 PerlIO_ungetc(fp,i);
3800 /* See if we know enough about I/O mechanism to cheat it ! */
3802 /* This used to be #ifdef test - it is made run-time test for ease
3803 of abstracting out stdio interface. One call should be cheap
3804 enough here - and may even be a macro allowing compile
3808 if (PerlIO_fast_gets(fp)) {
3811 * We're going to steal some values from the stdio struct
3812 * and put EVERYTHING in the innermost loop into registers.
3814 register STDCHAR *ptr;
3818 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3819 /* An ungetc()d char is handled separately from the regular
3820 * buffer, so we getc() it back out and stuff it in the buffer.
3822 i = PerlIO_getc(fp);
3823 if (i == EOF) return 0;
3824 *(--((*fp)->_ptr)) = (unsigned char) i;
3828 /* Here is some breathtakingly efficient cheating */
3830 cnt = PerlIO_get_cnt(fp); /* get count into register */
3831 (void)SvPOK_only(sv); /* validate pointer */
3832 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3833 if (cnt > 80 && SvLEN(sv) > append) {
3834 shortbuffered = cnt - SvLEN(sv) + append + 1;
3835 cnt -= shortbuffered;
3839 /* remember that cnt can be negative */
3840 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3845 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3846 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3847 DEBUG_P(PerlIO_printf(Perl_debug_log,
3848 "Screamer: entering, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3849 DEBUG_P(PerlIO_printf(Perl_debug_log,
3850 "Screamer: entering: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3851 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3852 (long)(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3857 while (cnt > 0) { /* this | eat */
3859 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3860 goto thats_all_folks; /* screams | sed :-) */
3864 Copy(ptr, bp, cnt, char); /* this | eat */
3865 bp += cnt; /* screams | dust */
3866 ptr += cnt; /* louder | sed :-) */
3871 if (shortbuffered) { /* oh well, must extend */
3872 cnt = shortbuffered;
3874 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3876 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3877 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3881 DEBUG_P(PerlIO_printf(Perl_debug_log,
3882 "Screamer: going to getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3883 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3884 DEBUG_P(PerlIO_printf(Perl_debug_log,
3885 "Screamer: pre: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3886 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3887 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3888 /* This used to call 'filbuf' in stdio form, but as that behaves like
3889 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3890 another abstraction. */
3891 i = PerlIO_getc(fp); /* get more characters */
3892 DEBUG_P(PerlIO_printf(Perl_debug_log,
3893 "Screamer: post: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3894 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3895 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3896 cnt = PerlIO_get_cnt(fp);
3897 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3898 DEBUG_P(PerlIO_printf(Perl_debug_log,
3899 "Screamer: after getc, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3901 if (i == EOF) /* all done for ever? */
3902 goto thats_really_all_folks;
3904 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3906 SvGROW(sv, bpx + cnt + 2);
3907 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3909 *bp++ = i; /* store character from PerlIO_getc */
3911 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3912 goto thats_all_folks;
3916 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3917 memNE((char*)bp - rslen, rsptr, rslen))
3918 goto screamer; /* go back to the fray */
3919 thats_really_all_folks:
3921 cnt += shortbuffered;
3922 DEBUG_P(PerlIO_printf(Perl_debug_log,
3923 "Screamer: quitting, ptr=%ld, cnt=%ld\n",(long)ptr,(long)cnt));
3924 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3925 DEBUG_P(PerlIO_printf(Perl_debug_log,
3926 "Screamer: end: FILE * thinks ptr=%ld, cnt=%ld, base=%ld\n",
3927 (long)PerlIO_get_ptr(fp), (long)PerlIO_get_cnt(fp),
3928 (long)(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3930 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3931 DEBUG_P(PerlIO_printf(Perl_debug_log,
3932 "Screamer: done, len=%ld, string=|%.*s|\n",
3933 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3938 /*The big, slow, and stupid way */
3941 /* Need to work around EPOC SDK features */
3942 /* On WINS: MS VC5 generates calls to _chkstk, */
3943 /* if a `large' stack frame is allocated */
3944 /* gcc on MARM does not generate calls like these */
3950 register STDCHAR *bpe = buf + sizeof(buf);
3952 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3953 ; /* keep reading */
3957 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3958 /* Accomodate broken VAXC compiler, which applies U8 cast to
3959 * both args of ?: operator, causing EOF to change into 255
3961 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3965 sv_catpvn(sv, (char *) buf, cnt);
3967 sv_setpvn(sv, (char *) buf, cnt);
3969 if (i != EOF && /* joy */
3971 SvCUR(sv) < rslen ||
3972 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3976 * If we're reading from a TTY and we get a short read,
3977 * indicating that the user hit his EOF character, we need
3978 * to notice it now, because if we try to read from the TTY
3979 * again, the EOF condition will disappear.
3981 * The comparison of cnt to sizeof(buf) is an optimization
3982 * that prevents unnecessary calls to feof().
3986 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3991 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3992 while (i != EOF) { /* to make sure file boundaries work right */
3993 i = PerlIO_getc(fp);
3995 PerlIO_ungetc(fp,i);
4002 win32_strip_return(sv);
4005 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4010 Perl_sv_inc(pTHX_ register SV *sv)
4019 if (SvTHINKFIRST(sv)) {
4020 if (SvREADONLY(sv)) {
4022 if (PL_curcop != &PL_compiling)
4023 Perl_croak(aTHX_ PL_no_modify);
4027 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4029 i = PTR2IV(SvRV(sv));
4034 flags = SvFLAGS(sv);
4035 if (flags & SVp_NOK) {
4036 (void)SvNOK_only(sv);
4040 if (flags & SVp_IOK) {
4042 if (SvUVX(sv) == UV_MAX)
4043 sv_setnv(sv, (NV)UV_MAX + 1.0);
4045 (void)SvIOK_only_UV(sv);
4048 if (SvIVX(sv) == IV_MAX)
4049 sv_setnv(sv, (NV)IV_MAX + 1.0);
4051 (void)SvIOK_only(sv);
4057 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4058 if ((flags & SVTYPEMASK) < SVt_PVNV)
4059 sv_upgrade(sv, SVt_NV);
4061 (void)SvNOK_only(sv);
4065 while (isALPHA(*d)) d++;
4066 while (isDIGIT(*d)) d++;
4068 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4072 while (d >= SvPVX(sv)) {
4080 /* MKS: The original code here died if letters weren't consecutive.
4081 * at least it didn't have to worry about non-C locales. The
4082 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4083 * arranged in order (although not consecutively) and that only
4084 * [A-Za-z] are accepted by isALPHA in the C locale.
4086 if (*d != 'z' && *d != 'Z') {
4087 do { ++*d; } while (!isALPHA(*d));
4090 *(d--) -= 'z' - 'a';
4095 *(d--) -= 'z' - 'a' + 1;
4099 /* oh,oh, the number grew */
4100 SvGROW(sv, SvCUR(sv) + 2);
4102 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4111 Perl_sv_dec(pTHX_ register SV *sv)
4119 if (SvTHINKFIRST(sv)) {
4120 if (SvREADONLY(sv)) {
4122 if (PL_curcop != &PL_compiling)
4123 Perl_croak(aTHX_ PL_no_modify);
4127 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4129 i = PTR2IV(SvRV(sv));
4134 flags = SvFLAGS(sv);
4135 if (flags & SVp_NOK) {
4137 (void)SvNOK_only(sv);
4140 if (flags & SVp_IOK) {
4142 if (SvUVX(sv) == 0) {
4143 (void)SvIOK_only(sv);
4147 (void)SvIOK_only_UV(sv);
4151 if (SvIVX(sv) == IV_MIN)
4152 sv_setnv(sv, (NV)IV_MIN - 1.0);
4154 (void)SvIOK_only(sv);
4160 if (!(flags & SVp_POK)) {
4161 if ((flags & SVTYPEMASK) < SVt_PVNV)
4162 sv_upgrade(sv, SVt_NV);
4164 (void)SvNOK_only(sv);
4167 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4170 /* Make a string that will exist for the duration of the expression
4171 * evaluation. Actually, it may have to last longer than that, but
4172 * hopefully we won't free it until it has been assigned to a
4173 * permanent location. */
4176 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4182 sv_setsv(sv,oldstr);
4184 PL_tmps_stack[++PL_tmps_ix] = sv;
4190 Perl_sv_newmortal(pTHX)
4196 SvFLAGS(sv) = SVs_TEMP;
4198 PL_tmps_stack[++PL_tmps_ix] = sv;
4202 /* same thing without the copying */
4205 Perl_sv_2mortal(pTHX_ register SV *sv)
4210 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4213 PL_tmps_stack[++PL_tmps_ix] = sv;
4219 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4226 sv_setpvn(sv,s,len);
4231 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4236 sv_setpvn(sv,s,len);
4240 #if defined(PERL_IMPLICIT_CONTEXT)
4242 Perl_newSVpvf_nocontext(const char* pat, ...)
4247 va_start(args, pat);
4248 sv = vnewSVpvf(pat, &args);
4255 Perl_newSVpvf(pTHX_ const char* pat, ...)
4259 va_start(args, pat);
4260 sv = vnewSVpvf(pat, &args);
4266 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4270 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4275 Perl_newSVnv(pTHX_ NV n)
4285 Perl_newSViv(pTHX_ IV i)
4295 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4301 sv_upgrade(sv, SVt_RV);
4309 Perl_newRV(pTHX_ SV *tmpRef)
4311 return newRV_noinc(SvREFCNT_inc(tmpRef));
4314 /* make an exact duplicate of old */
4317 Perl_newSVsv(pTHX_ register SV *old)
4324 if (SvTYPE(old) == SVTYPEMASK) {
4325 if (ckWARN_d(WARN_INTERNAL))
4326 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4341 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4349 char todo[PERL_UCHAR_MAX+1];
4354 if (!*s) { /* reset ?? searches */
4355 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4356 pm->op_pmdynflags &= ~PMdf_USED;
4361 /* reset variables */
4363 if (!HvARRAY(stash))
4366 Zero(todo, 256, char);
4368 i = (unsigned char)*s;
4372 max = (unsigned char)*s++;
4373 for ( ; i <= max; i++) {
4376 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4377 for (entry = HvARRAY(stash)[i];
4379 entry = HeNEXT(entry))
4381 if (!todo[(U8)*HeKEY(entry)])
4383 gv = (GV*)HeVAL(entry);
4385 if (SvTHINKFIRST(sv)) {
4386 if (!SvREADONLY(sv) && SvROK(sv))
4391 if (SvTYPE(sv) >= SVt_PV) {
4393 if (SvPVX(sv) != Nullch)
4400 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4402 #ifndef VMS /* VMS has no environ array */
4404 environ[0] = Nullch;
4413 Perl_sv_2io(pTHX_ SV *sv)
4419 switch (SvTYPE(sv)) {
4427 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4431 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4433 return sv_2io(SvRV(sv));
4434 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4440 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4447 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4454 return *gvp = Nullgv, Nullcv;
4455 switch (SvTYPE(sv)) {
4475 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4476 tryAMAGICunDEREF(to_cv);
4479 if (SvTYPE(sv) == SVt_PVCV) {
4488 Perl_croak(aTHX_ "Not a subroutine reference");
4493 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4499 if (lref && !GvCVu(gv)) {
4502 tmpsv = NEWSV(704,0);
4503 gv_efullname3(tmpsv, gv, Nullch);
4504 /* XXX this is probably not what they think they're getting.
4505 * It has the same effect as "sub name;", i.e. just a forward
4507 newSUB(start_subparse(FALSE, 0),
4508 newSVOP(OP_CONST, 0, tmpsv),
4513 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4520 Perl_sv_true(pTHX_ register SV *sv)
4527 if ((tXpv = (XPV*)SvANY(sv)) &&
4528 (*tXpv->xpv_pv > '0' ||
4529 tXpv->xpv_cur > 1 ||
4530 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4537 return SvIVX(sv) != 0;
4540 return SvNVX(sv) != 0.0;
4542 return sv_2bool(sv);
4548 Perl_sv_iv(pTHX_ register SV *sv)
4552 return (IV)SvUVX(sv);
4559 Perl_sv_uv(pTHX_ register SV *sv)
4564 return (UV)SvIVX(sv);
4570 Perl_sv_nv(pTHX_ register SV *sv)
4578 Perl_sv_pv(pTHX_ SV *sv)
4585 return sv_2pv(sv, &n_a);
4589 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4595 return sv_2pv(sv, lp);
4599 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4603 if (SvTHINKFIRST(sv) && !SvROK(sv))
4604 sv_force_normal(sv);
4610 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4612 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4613 PL_op_name[PL_op->op_type]);
4617 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4622 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4623 SvGROW(sv, len + 1);
4624 Move(s,SvPVX(sv),len,char);
4629 SvPOK_on(sv); /* validate pointer */
4631 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",
4632 (unsigned long)sv,SvPVX(sv)));
4639 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4641 if (ob && SvOBJECT(sv))
4642 return HvNAME(SvSTASH(sv));
4644 switch (SvTYPE(sv)) {
4658 case SVt_PVLV: return "LVALUE";
4659 case SVt_PVAV: return "ARRAY";
4660 case SVt_PVHV: return "HASH";
4661 case SVt_PVCV: return "CODE";
4662 case SVt_PVGV: return "GLOB";
4663 case SVt_PVFM: return "FORMAT";
4664 default: return "UNKNOWN";
4670 Perl_sv_isobject(pTHX_ SV *sv)
4685 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4697 return strEQ(HvNAME(SvSTASH(sv)), name);
4701 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4708 SV_CHECK_THINKFIRST(rv);
4711 if (SvTYPE(rv) < SVt_RV)
4712 sv_upgrade(rv, SVt_RV);
4719 HV* stash = gv_stashpv(classname, TRUE);
4720 (void)sv_bless(rv, stash);
4726 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4729 sv_setsv(rv, &PL_sv_undef);
4733 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4738 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4740 sv_setiv(newSVrv(rv,classname), iv);
4745 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4747 sv_setnv(newSVrv(rv,classname), nv);
4752 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4754 sv_setpvn(newSVrv(rv,classname), pv, n);
4759 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4764 Perl_croak(aTHX_ "Can't bless non-reference value");
4766 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4767 if (SvREADONLY(tmpRef))
4768 Perl_croak(aTHX_ PL_no_modify);
4769 if (SvOBJECT(tmpRef)) {
4770 if (SvTYPE(tmpRef) != SVt_PVIO)
4772 SvREFCNT_dec(SvSTASH(tmpRef));
4775 SvOBJECT_on(tmpRef);
4776 if (SvTYPE(tmpRef) != SVt_PVIO)
4778 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4779 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4790 S_sv_unglob(pTHX_ SV *sv)
4792 assert(SvTYPE(sv) == SVt_PVGV);
4797 SvREFCNT_dec(GvSTASH(sv));
4798 GvSTASH(sv) = Nullhv;
4800 sv_unmagic(sv, '*');
4801 Safefree(GvNAME(sv));
4803 SvFLAGS(sv) &= ~SVTYPEMASK;
4804 SvFLAGS(sv) |= SVt_PVMG;
4808 Perl_sv_unref(pTHX_ SV *sv)
4812 if (SvWEAKREF(sv)) {
4820 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4823 sv_2mortal(rv); /* Schedule for freeing later */
4827 Perl_sv_taint(pTHX_ SV *sv)
4829 sv_magic((sv), Nullsv, 't', Nullch, 0);
4833 Perl_sv_untaint(pTHX_ SV *sv)
4835 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4836 MAGIC *mg = mg_find(sv, 't');
4843 Perl_sv_tainted(pTHX_ SV *sv)
4845 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4846 MAGIC *mg = mg_find(sv, 't');
4847 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4854 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4856 char buf[TYPE_CHARS(UV)];
4858 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4860 sv_setpvn(sv, ptr, ebuf - ptr);
4865 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4867 char buf[TYPE_CHARS(UV)];
4869 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4871 sv_setpvn(sv, ptr, ebuf - ptr);
4875 #if defined(PERL_IMPLICIT_CONTEXT)
4877 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4881 va_start(args, pat);
4882 sv_vsetpvf(sv, pat, &args);
4888 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4892 va_start(args, pat);
4893 sv_vsetpvf_mg(sv, pat, &args);
4899 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4902 va_start(args, pat);
4903 sv_vsetpvf(sv, pat, &args);
4908 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4910 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4914 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4917 va_start(args, pat);
4918 sv_vsetpvf_mg(sv, pat, &args);
4923 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4925 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4929 #if defined(PERL_IMPLICIT_CONTEXT)
4931 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4935 va_start(args, pat);
4936 sv_vcatpvf(sv, pat, &args);
4941 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4945 va_start(args, pat);
4946 sv_vcatpvf_mg(sv, pat, &args);
4952 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4955 va_start(args, pat);
4956 sv_vcatpvf(sv, pat, &args);
4961 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4963 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4967 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4970 va_start(args, pat);
4971 sv_vcatpvf_mg(sv, pat, &args);
4976 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4978 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4983 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
4985 sv_setpvn(sv, "", 0);
4986 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
4990 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
4998 static char nullstr[] = "(null)";
5000 /* no matter what, this is a string now */
5001 (void)SvPV_force(sv, origlen);
5003 /* special-case "", "%s", and "%_" */
5006 if (patlen == 2 && pat[0] == '%') {
5010 char *s = va_arg(*args, char*);
5011 sv_catpv(sv, s ? s : nullstr);
5013 else if (svix < svmax)
5014 sv_catsv(sv, *svargs);
5018 sv_catsv(sv, va_arg(*args, SV*));
5021 /* See comment on '_' below */
5026 patend = (char*)pat + patlen;
5027 for (p = (char*)pat; p < patend; p = q) {
5035 bool has_precis = FALSE;
5040 STRLEN esignlen = 0;
5042 char *eptr = Nullch;
5044 /* Times 4: a decimal digit takes more than 3 binary digits.
5045 * NV_DIG: mantissa takes than many decimal digits.
5046 * Plus 32: Playing safe. */
5047 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5048 /* large enough for "%#.#f" --chip */
5049 /* what about long double NVs? --jhi */
5060 for (q = p; q < patend && *q != '%'; ++q) ;
5062 sv_catpvn(sv, p, q - p);
5100 case '1': case '2': case '3':
5101 case '4': case '5': case '6':
5102 case '7': case '8': case '9':
5105 width = width * 10 + (*q++ - '0');
5110 i = va_arg(*args, int);
5112 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5114 width = (i < 0) ? -i : i;
5125 i = va_arg(*args, int);
5127 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5128 precis = (i < 0) ? 0 : i;
5134 precis = precis * 10 + (*q++ - '0');
5144 if (*(q + 1) == 'l') { /* lld */
5176 uv = va_arg(*args, int);
5178 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5180 eptr = (char*)utf8buf;
5181 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5185 c = va_arg(*args, int);
5187 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5194 eptr = va_arg(*args, char*);
5196 elen = strlen(eptr);
5199 elen = sizeof nullstr - 1;
5202 else if (svix < svmax) {
5203 eptr = SvPVx(svargs[svix++], elen);
5205 if (has_precis && precis < elen) {
5207 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5210 if (width) { /* fudge width (can't fudge elen) */
5211 width += elen - sv_len_utf8(svargs[svix - 1]);
5219 * The "%_" hack might have to be changed someday,
5220 * if ISO or ANSI decide to use '_' for something.
5221 * So we keep it hidden from users' code.
5225 eptr = SvPVx(va_arg(*args, SV*), elen);
5228 if (has_precis && elen > precis)
5236 uv = PTR2UV(va_arg(*args, void*));
5238 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5253 case 'h': iv = (short)va_arg(*args, int); break;
5254 default: iv = va_arg(*args, int); break;
5255 case 'l': iv = va_arg(*args, long); break;
5256 case 'V': iv = va_arg(*args, IV); break;
5258 case 'q': iv = va_arg(*args, Quad_t); break;
5263 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5265 case 'h': iv = (short)iv; break;
5266 default: iv = (int)iv; break;
5267 case 'l': iv = (long)iv; break;
5270 case 'q': iv = (Quad_t)iv; break;
5277 esignbuf[esignlen++] = plus;
5281 esignbuf[esignlen++] = '-';
5319 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5320 default: uv = va_arg(*args, unsigned); break;
5321 case 'l': uv = va_arg(*args, unsigned long); break;
5322 case 'V': uv = va_arg(*args, UV); break;
5324 case 'q': uv = va_arg(*args, Quad_t); break;
5329 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5331 case 'h': uv = (unsigned short)uv; break;
5332 default: uv = (unsigned)uv; break;
5333 case 'l': uv = (unsigned long)uv; break;
5336 case 'q': uv = (Quad_t)uv; break;
5342 eptr = ebuf + sizeof ebuf;
5348 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5354 esignbuf[esignlen++] = '0';
5355 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5361 *--eptr = '0' + dig;
5363 if (alt && *eptr != '0')
5369 *--eptr = '0' + dig;
5372 esignbuf[esignlen++] = '0';
5373 esignbuf[esignlen++] = 'b';
5376 default: /* it had better be ten or less */
5377 #if defined(PERL_Y2KWARN)
5378 if (ckWARN(WARN_MISC)) {
5380 char *s = SvPV(sv,n);
5381 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5382 && (n == 2 || !isDIGIT(s[n-3])))
5384 Perl_warner(aTHX_ WARN_MISC,
5385 "Possible Y2K bug: %%%c %s",
5386 c, "format string following '19'");
5392 *--eptr = '0' + dig;
5393 } while (uv /= base);
5396 elen = (ebuf + sizeof ebuf) - eptr;
5399 zeros = precis - elen;
5400 else if (precis == 0 && elen == 1 && *eptr == '0')
5405 /* FLOATING POINT */
5408 c = 'f'; /* maybe %F isn't supported here */
5414 /* This is evil, but floating point is even more evil */
5417 nv = va_arg(*args, NV);
5419 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5422 if (c != 'e' && c != 'E') {
5424 (void)frexp(nv, &i);
5425 if (i == PERL_INT_MIN)
5426 Perl_die(aTHX_ "panic: frexp");
5428 need = BIT_DIGITS(i);
5430 need += has_precis ? precis : 6; /* known default */
5434 need += 20; /* fudge factor */
5435 if (PL_efloatsize < need) {
5436 Safefree(PL_efloatbuf);
5437 PL_efloatsize = need + 20; /* more fudge */
5438 New(906, PL_efloatbuf, PL_efloatsize, char);
5439 PL_efloatbuf[0] = '\0';
5442 eptr = ebuf + sizeof ebuf;
5445 #ifdef USE_LONG_DOUBLE
5447 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5448 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5453 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5458 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5471 RESTORE_NUMERIC_STANDARD();
5472 (void)sprintf(PL_efloatbuf, eptr, nv);
5473 RESTORE_NUMERIC_LOCAL();
5476 eptr = PL_efloatbuf;
5477 elen = strlen(PL_efloatbuf);
5479 #ifdef USE_LOCALE_NUMERIC
5481 * User-defined locales may include arbitrary characters.
5482 * And, unfortunately, some (broken) systems may allow the
5483 * "C" locale to be overridden by a malicious user.
5484 * XXX This is an extreme way to cope with broken systems.
5486 if (maybe_tainted && PL_tainting) {
5487 /* safe if it matches /[-+]?\d*(\.\d*)?([eE][-+]?\d*)?/ */
5488 if (*eptr == '-' || *eptr == '+')
5490 while (isDIGIT(*eptr))
5494 while (isDIGIT(*eptr))
5497 if (*eptr == 'e' || *eptr == 'E') {
5499 if (*eptr == '-' || *eptr == '+')
5501 while (isDIGIT(*eptr))
5505 *maybe_tainted = TRUE; /* results are suspect */
5506 eptr = PL_efloatbuf;
5508 #endif /* USE_LOCALE_NUMERIC */
5515 i = SvCUR(sv) - origlen;
5518 case 'h': *(va_arg(*args, short*)) = i; break;
5519 default: *(va_arg(*args, int*)) = i; break;
5520 case 'l': *(va_arg(*args, long*)) = i; break;
5521 case 'V': *(va_arg(*args, IV*)) = i; break;
5523 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5527 else if (svix < svmax)
5528 sv_setuv(svargs[svix++], (UV)i);
5529 continue; /* not "break" */
5535 if (!args && ckWARN(WARN_PRINTF) &&
5536 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5537 SV *msg = sv_newmortal();
5538 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5539 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5542 Perl_sv_catpvf(aTHX_ msg,
5543 "\"%%%c\"", c & 0xFF);
5545 Perl_sv_catpvf(aTHX_ msg,
5546 "\"%%\\%03"UVof"\"",
5549 sv_catpv(msg, "end of string");
5550 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5553 /* output mangled stuff ... */
5559 /* ... right here, because formatting flags should not apply */
5560 SvGROW(sv, SvCUR(sv) + elen + 1);
5562 memcpy(p, eptr, elen);
5565 SvCUR(sv) = p - SvPVX(sv);
5566 continue; /* not "break" */
5569 have = esignlen + zeros + elen;
5570 need = (have > width ? have : width);
5573 SvGROW(sv, SvCUR(sv) + need + 1);
5575 if (esignlen && fill == '0') {
5576 for (i = 0; i < esignlen; i++)
5580 memset(p, fill, gap);
5583 if (esignlen && fill != '0') {
5584 for (i = 0; i < esignlen; i++)
5588 for (i = zeros; i; i--)
5592 memcpy(p, eptr, elen);
5596 memset(p, ' ', gap);
5600 SvCUR(sv) = p - SvPVX(sv);
5611 do_report_used(pTHXo_ SV *sv)
5613 if (SvTYPE(sv) != SVTYPEMASK) {
5614 /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */
5615 PerlIO_printf(PerlIO_stderr(), "****\n");
5621 do_clean_objs(pTHXo_ SV *sv)
5625 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5626 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
5632 /* XXX Might want to check arrays, etc. */
5635 #ifndef DISABLE_DESTRUCTOR_KLUDGE
5637 do_clean_named_objs(pTHXo_ SV *sv)
5639 if (SvTYPE(sv) == SVt_PVGV) {
5640 if ( SvOBJECT(GvSV(sv)) ||
5641 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
5642 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
5643 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
5644 GvCV(sv) && SvOBJECT(GvCV(sv)) )
5646 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
5654 do_clean_all(pTHXo_ SV *sv)
5656 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );)
5657 SvFLAGS(sv) |= SVf_BREAK;