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%"UVxf,
197 #else /* ! DEBUGGING */
199 #define del_SV(p) plant_SV(p)
201 #endif /* DEBUGGING */
204 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
209 Zero(sva, size, char);
211 /* The first SV in an arena isn't an SV. */
212 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
213 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
214 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
216 PL_sv_arenaroot = sva;
217 PL_sv_root = sva + 1;
219 svend = &sva[SvREFCNT(sva) - 1];
222 SvANY(sv) = (void *)(SV*)(sv + 1);
223 SvFLAGS(sv) = SVTYPEMASK;
227 SvFLAGS(sv) = SVTYPEMASK;
230 /* sv_mutex must be held while calling more_sv() */
237 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
238 PL_nice_chunk = Nullch;
241 char *chunk; /* must use New here to match call to */
242 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
243 sv_add_arena(chunk, 1008, 0);
250 S_visit(pTHX_ SVFUNC_t f)
256 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
257 svend = &sva[SvREFCNT(sva)];
258 for (sv = sva + 1; sv < svend; ++sv) {
259 if (SvTYPE(sv) != SVTYPEMASK)
268 Perl_sv_report_used(pTHX)
270 visit(do_report_used);
274 Perl_sv_clean_objs(pTHX)
276 PL_in_clean_objs = TRUE;
277 visit(do_clean_objs);
278 #ifndef DISABLE_DESTRUCTOR_KLUDGE
279 /* some barnacles may yet remain, clinging to typeglobs */
280 visit(do_clean_named_objs);
282 PL_in_clean_objs = FALSE;
286 Perl_sv_clean_all(pTHX)
288 PL_in_clean_all = TRUE;
290 PL_in_clean_all = FALSE;
294 Perl_sv_free_arenas(pTHX)
299 /* Free arenas here, but be careful about fake ones. (We assume
300 contiguity of the fake ones with the corresponding real ones.) */
302 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
303 svanext = (SV*) SvANY(sva);
304 while (svanext && SvFAKE(svanext))
305 svanext = (SV*) SvANY(svanext);
308 Safefree((void *)sva);
312 Safefree(PL_nice_chunk);
313 PL_nice_chunk = Nullch;
314 PL_nice_chunk_size = 0;
328 * See comment in more_xiv() -- RAM.
330 PL_xiv_root = *(IV**)xiv;
332 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
336 S_del_xiv(pTHX_ XPVIV *p)
338 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
340 *(IV**)xiv = PL_xiv_root;
351 New(705, ptr, 1008/sizeof(XPV), XPV);
352 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
353 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
356 xivend = &xiv[1008 / sizeof(IV) - 1];
357 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
359 while (xiv < xivend) {
360 *(IV**)xiv = (IV *)(xiv + 1);
374 PL_xnv_root = *(NV**)xnv;
376 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
380 S_del_xnv(pTHX_ XPVNV *p)
382 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
384 *(NV**)xnv = PL_xnv_root;
394 New(711, xnv, 1008/sizeof(NV), NV);
395 xnvend = &xnv[1008 / sizeof(NV) - 1];
396 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
398 while (xnv < xnvend) {
399 *(NV**)xnv = (NV*)(xnv + 1);
413 PL_xrv_root = (XRV*)xrv->xrv_rv;
419 S_del_xrv(pTHX_ XRV *p)
422 p->xrv_rv = (SV*)PL_xrv_root;
431 register XRV* xrvend;
432 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
434 xrvend = &xrv[1008 / sizeof(XRV) - 1];
435 while (xrv < xrvend) {
436 xrv->xrv_rv = (SV*)(xrv + 1);
450 PL_xpv_root = (XPV*)xpv->xpv_pv;
456 S_del_xpv(pTHX_ XPV *p)
459 p->xpv_pv = (char*)PL_xpv_root;
468 register XPV* xpvend;
469 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
471 xpvend = &xpv[1008 / sizeof(XPV) - 1];
472 while (xpv < xpvend) {
473 xpv->xpv_pv = (char*)(xpv + 1);
486 xpviv = PL_xpviv_root;
487 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
493 S_del_xpviv(pTHX_ XPVIV *p)
496 p->xpv_pv = (char*)PL_xpviv_root;
505 register XPVIV* xpviv;
506 register XPVIV* xpvivend;
507 New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
508 xpviv = PL_xpviv_root;
509 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
510 while (xpviv < xpvivend) {
511 xpviv->xpv_pv = (char*)(xpviv + 1);
525 xpvnv = PL_xpvnv_root;
526 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
532 S_del_xpvnv(pTHX_ XPVNV *p)
535 p->xpv_pv = (char*)PL_xpvnv_root;
544 register XPVNV* xpvnv;
545 register XPVNV* xpvnvend;
546 New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
547 xpvnv = PL_xpvnv_root;
548 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
549 while (xpvnv < xpvnvend) {
550 xpvnv->xpv_pv = (char*)(xpvnv + 1);
565 xpvcv = PL_xpvcv_root;
566 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
572 S_del_xpvcv(pTHX_ XPVCV *p)
575 p->xpv_pv = (char*)PL_xpvcv_root;
584 register XPVCV* xpvcv;
585 register XPVCV* xpvcvend;
586 New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
587 xpvcv = PL_xpvcv_root;
588 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
589 while (xpvcv < xpvcvend) {
590 xpvcv->xpv_pv = (char*)(xpvcv + 1);
605 xpvav = PL_xpvav_root;
606 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
612 S_del_xpvav(pTHX_ XPVAV *p)
615 p->xav_array = (char*)PL_xpvav_root;
624 register XPVAV* xpvav;
625 register XPVAV* xpvavend;
626 New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
627 xpvav = PL_xpvav_root;
628 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
629 while (xpvav < xpvavend) {
630 xpvav->xav_array = (char*)(xpvav + 1);
633 xpvav->xav_array = 0;
645 xpvhv = PL_xpvhv_root;
646 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
652 S_del_xpvhv(pTHX_ XPVHV *p)
655 p->xhv_array = (char*)PL_xpvhv_root;
664 register XPVHV* xpvhv;
665 register XPVHV* xpvhvend;
666 New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
667 xpvhv = PL_xpvhv_root;
668 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
669 while (xpvhv < xpvhvend) {
670 xpvhv->xhv_array = (char*)(xpvhv + 1);
673 xpvhv->xhv_array = 0;
684 xpvmg = PL_xpvmg_root;
685 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
691 S_del_xpvmg(pTHX_ XPVMG *p)
694 p->xpv_pv = (char*)PL_xpvmg_root;
703 register XPVMG* xpvmg;
704 register XPVMG* xpvmgend;
705 New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
706 xpvmg = PL_xpvmg_root;
707 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
708 while (xpvmg < xpvmgend) {
709 xpvmg->xpv_pv = (char*)(xpvmg + 1);
724 xpvlv = PL_xpvlv_root;
725 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
731 S_del_xpvlv(pTHX_ XPVLV *p)
734 p->xpv_pv = (char*)PL_xpvlv_root;
743 register XPVLV* xpvlv;
744 register XPVLV* xpvlvend;
745 New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
746 xpvlv = PL_xpvlv_root;
747 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
748 while (xpvlv < xpvlvend) {
749 xpvlv->xpv_pv = (char*)(xpvlv + 1);
763 xpvbm = PL_xpvbm_root;
764 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
770 S_del_xpvbm(pTHX_ XPVBM *p)
773 p->xpv_pv = (char*)PL_xpvbm_root;
782 register XPVBM* xpvbm;
783 register XPVBM* xpvbmend;
784 New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
785 xpvbm = PL_xpvbm_root;
786 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
787 while (xpvbm < xpvbmend) {
788 xpvbm->xpv_pv = (char*)(xpvbm + 1);
795 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
796 #define del_XIV(p) Safefree((char*)p)
798 #define new_XIV() (void*)new_xiv()
799 #define del_XIV(p) del_xiv((XPVIV*) p)
803 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
804 #define del_XNV(p) Safefree((char*)p)
806 #define new_XNV() (void*)new_xnv()
807 #define del_XNV(p) del_xnv((XPVNV*) p)
811 #define new_XRV() (void*)safemalloc(sizeof(XRV))
812 #define del_XRV(p) Safefree((char*)p)
814 #define new_XRV() (void*)new_xrv()
815 #define del_XRV(p) del_xrv((XRV*) p)
819 #define new_XPV() (void*)safemalloc(sizeof(XPV))
820 #define del_XPV(p) Safefree((char*)p)
822 #define new_XPV() (void*)new_xpv()
823 #define del_XPV(p) del_xpv((XPV *)p)
827 # define my_safemalloc(s) safemalloc(s)
828 # define my_safefree(s) safefree(s)
831 S_my_safemalloc(MEM_SIZE size)
834 New(717, p, size, char);
837 # define my_safefree(s) Safefree(s)
841 #define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
842 #define del_XPVIV(p) Safefree((char*)p)
844 #define new_XPVIV() (void*)new_xpviv()
845 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
849 #define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
850 #define del_XPVNV(p) Safefree((char*)p)
852 #define new_XPVNV() (void*)new_xpvnv()
853 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
858 #define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
859 #define del_XPVCV(p) Safefree((char*)p)
861 #define new_XPVCV() (void*)new_xpvcv()
862 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
866 #define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
867 #define del_XPVAV(p) Safefree((char*)p)
869 #define new_XPVAV() (void*)new_xpvav()
870 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
874 #define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
875 #define del_XPVHV(p) Safefree((char*)p)
877 #define new_XPVHV() (void*)new_xpvhv()
878 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
882 #define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
883 #define del_XPVMG(p) Safefree((char*)p)
885 #define new_XPVMG() (void*)new_xpvmg()
886 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
890 #define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
891 #define del_XPVLV(p) Safefree((char*)p)
893 #define new_XPVLV() (void*)new_xpvlv()
894 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
897 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
898 #define del_XPVGV(p) my_safefree((char*)p)
901 #define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
902 #define del_XPVBM(p) Safefree((char*)p)
904 #define new_XPVBM() (void*)new_xpvbm()
905 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
908 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
909 #define del_XPVFM(p) my_safefree((char*)p)
911 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
912 #define del_XPVIO(p) my_safefree((char*)p)
915 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
925 if (SvTYPE(sv) == mt)
931 switch (SvTYPE(sv)) {
952 else if (mt < SVt_PVIV)
969 pv = (char*)SvRV(sv);
989 else if (mt == SVt_NV)
1000 del_XPVIV(SvANY(sv));
1010 del_XPVNV(SvANY(sv));
1018 magic = SvMAGIC(sv);
1019 stash = SvSTASH(sv);
1020 del_XPVMG(SvANY(sv));
1023 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1028 Perl_croak(aTHX_ "Can't upgrade to undef");
1030 SvANY(sv) = new_XIV();
1034 SvANY(sv) = new_XNV();
1038 SvANY(sv) = new_XRV();
1042 SvANY(sv) = new_XPV();
1048 SvANY(sv) = new_XPVIV();
1058 SvANY(sv) = new_XPVNV();
1066 SvANY(sv) = new_XPVMG();
1072 SvMAGIC(sv) = magic;
1073 SvSTASH(sv) = stash;
1076 SvANY(sv) = new_XPVLV();
1082 SvMAGIC(sv) = magic;
1083 SvSTASH(sv) = stash;
1090 SvANY(sv) = new_XPVAV();
1098 SvMAGIC(sv) = magic;
1099 SvSTASH(sv) = stash;
1105 SvANY(sv) = new_XPVHV();
1113 SvMAGIC(sv) = magic;
1114 SvSTASH(sv) = stash;
1121 SvANY(sv) = new_XPVCV();
1122 Zero(SvANY(sv), 1, XPVCV);
1128 SvMAGIC(sv) = magic;
1129 SvSTASH(sv) = stash;
1132 SvANY(sv) = new_XPVGV();
1138 SvMAGIC(sv) = magic;
1139 SvSTASH(sv) = stash;
1147 SvANY(sv) = new_XPVBM();
1153 SvMAGIC(sv) = magic;
1154 SvSTASH(sv) = stash;
1160 SvANY(sv) = new_XPVFM();
1161 Zero(SvANY(sv), 1, XPVFM);
1167 SvMAGIC(sv) = magic;
1168 SvSTASH(sv) = stash;
1171 SvANY(sv) = new_XPVIO();
1172 Zero(SvANY(sv), 1, XPVIO);
1178 SvMAGIC(sv) = magic;
1179 SvSTASH(sv) = stash;
1180 IoPAGE_LEN(sv) = 60;
1183 SvFLAGS(sv) &= ~SVTYPEMASK;
1189 Perl_sv_backoff(pTHX_ register SV *sv)
1193 char *s = SvPVX(sv);
1194 SvLEN(sv) += SvIVX(sv);
1195 SvPVX(sv) -= SvIVX(sv);
1197 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1199 SvFLAGS(sv) &= ~SVf_OOK;
1204 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1208 #ifdef HAS_64K_LIMIT
1209 if (newlen >= 0x10000) {
1210 PerlIO_printf(Perl_debug_log,
1211 "Allocation too large: %"UVxf"\n", (UV)newlen);
1214 #endif /* HAS_64K_LIMIT */
1217 if (SvTYPE(sv) < SVt_PV) {
1218 sv_upgrade(sv, SVt_PV);
1221 else if (SvOOK(sv)) { /* pv is offset? */
1224 if (newlen > SvLEN(sv))
1225 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1226 #ifdef HAS_64K_LIMIT
1227 if (newlen >= 0x10000)
1233 if (newlen > SvLEN(sv)) { /* need more room? */
1234 if (SvLEN(sv) && s) {
1235 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
1236 STRLEN l = malloced_size((void*)SvPVX(sv));
1242 Renew(s,newlen,char);
1245 New(703,s,newlen,char);
1247 SvLEN_set(sv, newlen);
1253 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1255 SV_CHECK_THINKFIRST(sv);
1256 switch (SvTYPE(sv)) {
1258 sv_upgrade(sv, SVt_IV);
1261 sv_upgrade(sv, SVt_PVNV);
1265 sv_upgrade(sv, SVt_PVIV);
1276 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1277 PL_op_desc[PL_op->op_type]);
1280 (void)SvIOK_only(sv); /* validate number */
1286 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1293 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1301 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1308 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1310 SV_CHECK_THINKFIRST(sv);
1311 switch (SvTYPE(sv)) {
1314 sv_upgrade(sv, SVt_NV);
1319 sv_upgrade(sv, SVt_PVNV);
1330 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1331 PL_op_name[PL_op->op_type]);
1335 (void)SvNOK_only(sv); /* validate number */
1340 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1347 S_not_a_number(pTHX_ SV *sv)
1353 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1354 /* each *s can expand to 4 chars + "...\0",
1355 i.e. need room for 8 chars */
1357 for (s = SvPVX(sv); *s && d < limit; s++) {
1359 if (ch & 128 && !isPRINT_LC(ch)) {
1368 else if (ch == '\r') {
1372 else if (ch == '\f') {
1376 else if (ch == '\\') {
1380 else if (isPRINT_LC(ch))
1395 Perl_warner(aTHX_ WARN_NUMERIC,
1396 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1397 PL_op_desc[PL_op->op_type]);
1399 Perl_warner(aTHX_ WARN_NUMERIC,
1400 "Argument \"%s\" isn't numeric", tmpbuf);
1403 /* the number can be converted to integer with atol() or atoll() */
1404 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1405 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1406 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1407 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1409 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1410 until proven guilty, assume that things are not that bad... */
1413 Perl_sv_2iv(pTHX_ register SV *sv)
1417 if (SvGMAGICAL(sv)) {
1422 return I_V(SvNVX(sv));
1424 if (SvPOKp(sv) && SvLEN(sv))
1427 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1429 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1430 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1435 if (SvTHINKFIRST(sv)) {
1438 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1439 return SvIV(tmpstr);
1440 return PTR2IV(SvRV(sv));
1442 if (SvREADONLY(sv) && !SvOK(sv)) {
1444 if (ckWARN(WARN_UNINITIALIZED))
1445 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1451 return (IV)(SvUVX(sv));
1458 /* We can cache the IV/UV value even if it not good enough
1459 * to reconstruct NV, since the conversion to PV will prefer
1463 if (SvTYPE(sv) == SVt_NV)
1464 sv_upgrade(sv, SVt_PVNV);
1467 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1468 SvIVX(sv) = I_V(SvNVX(sv));
1470 SvUVX(sv) = U_V(SvNVX(sv));
1473 DEBUG_c(PerlIO_printf(Perl_debug_log,
1474 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1478 return (IV)SvUVX(sv);
1481 else if (SvPOKp(sv) && SvLEN(sv)) {
1482 I32 numtype = looks_like_number(sv);
1484 /* We want to avoid a possible problem when we cache an IV which
1485 may be later translated to an NV, and the resulting NV is not
1486 the translation of the initial data.
1488 This means that if we cache such an IV, we need to cache the
1489 NV as well. Moreover, we trade speed for space, and do not
1490 cache the NV if not needed.
1492 if (numtype & IS_NUMBER_NOT_IV) {
1493 /* May be not an integer. Need to cache NV if we cache IV
1494 * - otherwise future conversion to NV will be wrong. */
1497 d = Atof(SvPVX(sv));
1499 if (SvTYPE(sv) < SVt_PVNV)
1500 sv_upgrade(sv, SVt_PVNV);
1504 #if defined(USE_LONG_DOUBLE)
1505 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1506 PTR2UV(sv), SvNVX(sv)));
1508 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1509 PTR2UV(sv), SvNVX(sv)));
1511 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1512 SvIVX(sv) = I_V(SvNVX(sv));
1514 SvUVX(sv) = U_V(SvNVX(sv));
1520 /* The NV may be reconstructed from IV - safe to cache IV,
1521 which may be calculated by atol(). */
1522 if (SvTYPE(sv) == SVt_PV)
1523 sv_upgrade(sv, SVt_PVIV);
1525 SvIVX(sv) = Atol(SvPVX(sv));
1527 else { /* Not a number. Cache 0. */
1530 if (SvTYPE(sv) < SVt_PVIV)
1531 sv_upgrade(sv, SVt_PVIV);
1534 if (ckWARN(WARN_NUMERIC))
1540 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1541 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1542 if (SvTYPE(sv) < SVt_IV)
1543 /* Typically the caller expects that sv_any is not NULL now. */
1544 sv_upgrade(sv, SVt_IV);
1547 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1548 PTR2UV(sv),SvIVX(sv)));
1549 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1553 Perl_sv_2uv(pTHX_ register SV *sv)
1557 if (SvGMAGICAL(sv)) {
1562 return U_V(SvNVX(sv));
1563 if (SvPOKp(sv) && SvLEN(sv))
1566 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1568 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1569 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1574 if (SvTHINKFIRST(sv)) {
1577 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1578 return SvUV(tmpstr);
1579 return PTR2UV(SvRV(sv));
1581 if (SvREADONLY(sv) && !SvOK(sv)) {
1583 if (ckWARN(WARN_UNINITIALIZED))
1584 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1593 return (UV)SvIVX(sv);
1597 /* We can cache the IV/UV value even if it not good enough
1598 * to reconstruct NV, since the conversion to PV will prefer
1601 if (SvTYPE(sv) == SVt_NV)
1602 sv_upgrade(sv, SVt_PVNV);
1604 if (SvNVX(sv) >= -0.5) {
1606 SvUVX(sv) = U_V(SvNVX(sv));
1609 SvIVX(sv) = I_V(SvNVX(sv));
1611 DEBUG_c(PerlIO_printf(Perl_debug_log,
1612 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1615 (IV)(UV)SvIVX(sv)));
1616 return (UV)SvIVX(sv);
1619 else if (SvPOKp(sv) && SvLEN(sv)) {
1620 I32 numtype = looks_like_number(sv);
1622 /* We want to avoid a possible problem when we cache a UV which
1623 may be later translated to an NV, and the resulting NV is not
1624 the translation of the initial data.
1626 This means that if we cache such a UV, we need to cache the
1627 NV as well. Moreover, we trade speed for space, and do not
1628 cache the NV if not needed.
1630 if (numtype & IS_NUMBER_NOT_IV) {
1631 /* May be not an integer. Need to cache NV if we cache IV
1632 * - otherwise future conversion to NV will be wrong. */
1635 d = Atof(SvPVX(sv));
1637 if (SvTYPE(sv) < SVt_PVNV)
1638 sv_upgrade(sv, SVt_PVNV);
1642 #if defined(USE_LONG_DOUBLE)
1643 DEBUG_c(PerlIO_printf(Perl_debug_log,
1644 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1645 PTR2UV(sv), SvNVX(sv)));
1647 DEBUG_c(PerlIO_printf(Perl_debug_log,
1648 "0x%"UVxf" 2nv(%g)\n",
1649 PTR2UV(sv), SvNVX(sv)));
1651 if (SvNVX(sv) < -0.5) {
1652 SvIVX(sv) = I_V(SvNVX(sv));
1655 SvUVX(sv) = U_V(SvNVX(sv));
1659 else if (numtype & IS_NUMBER_NEG) {
1660 /* The NV may be reconstructed from IV - safe to cache IV,
1661 which may be calculated by atol(). */
1662 if (SvTYPE(sv) == SVt_PV)
1663 sv_upgrade(sv, SVt_PVIV);
1665 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1667 else if (numtype) { /* Non-negative */
1668 /* The NV may be reconstructed from UV - safe to cache UV,
1669 which may be calculated by strtoul()/atol. */
1670 if (SvTYPE(sv) == SVt_PV)
1671 sv_upgrade(sv, SVt_PVIV);
1673 (void)SvIsUV_on(sv);
1675 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1676 #else /* no atou(), but we know the number fits into IV... */
1677 /* The only problem may be if it is negative... */
1678 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1681 else { /* Not a number. Cache 0. */
1684 if (SvTYPE(sv) < SVt_PVIV)
1685 sv_upgrade(sv, SVt_PVIV);
1686 SvUVX(sv) = 0; /* We assume that 0s have the
1687 same bitmap in IV and UV. */
1689 (void)SvIsUV_on(sv);
1690 if (ckWARN(WARN_NUMERIC))
1695 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1697 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1698 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1700 if (SvTYPE(sv) < SVt_IV)
1701 /* Typically the caller expects that sv_any is not NULL now. */
1702 sv_upgrade(sv, SVt_IV);
1706 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1708 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1712 Perl_sv_2nv(pTHX_ register SV *sv)
1716 if (SvGMAGICAL(sv)) {
1720 if (SvPOKp(sv) && SvLEN(sv)) {
1722 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1724 return Atof(SvPVX(sv));
1728 return (NV)SvUVX(sv);
1730 return (NV)SvIVX(sv);
1733 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1735 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1736 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1741 if (SvTHINKFIRST(sv)) {
1744 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1745 return SvNV(tmpstr);
1746 return PTR2NV(SvRV(sv));
1748 if (SvREADONLY(sv) && !SvOK(sv)) {
1750 if (ckWARN(WARN_UNINITIALIZED))
1751 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1755 if (SvTYPE(sv) < SVt_NV) {
1756 if (SvTYPE(sv) == SVt_IV)
1757 sv_upgrade(sv, SVt_PVNV);
1759 sv_upgrade(sv, SVt_NV);
1760 #if defined(USE_LONG_DOUBLE)
1762 RESTORE_NUMERIC_STANDARD();
1763 PerlIO_printf(Perl_debug_log,
1764 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1765 PTR2UV(sv), SvNVX(sv));
1766 RESTORE_NUMERIC_LOCAL();
1770 RESTORE_NUMERIC_STANDARD();
1771 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1772 PTR2UV(sv), SvNVX(sv));
1773 RESTORE_NUMERIC_LOCAL();
1777 else if (SvTYPE(sv) < SVt_PVNV)
1778 sv_upgrade(sv, SVt_PVNV);
1780 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1782 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1784 else if (SvPOKp(sv) && SvLEN(sv)) {
1786 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1788 SvNVX(sv) = Atof(SvPVX(sv));
1792 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1793 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
1794 if (SvTYPE(sv) < SVt_NV)
1795 /* Typically the caller expects that sv_any is not NULL now. */
1796 sv_upgrade(sv, SVt_NV);
1800 #if defined(USE_LONG_DOUBLE)
1802 RESTORE_NUMERIC_STANDARD();
1803 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1804 PTR2UV(sv), SvNVX(sv));
1805 RESTORE_NUMERIC_LOCAL();
1809 RESTORE_NUMERIC_STANDARD();
1810 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1811 PTR2UV(sv), SvNVX(sv));
1812 RESTORE_NUMERIC_LOCAL();
1819 S_asIV(pTHX_ SV *sv)
1821 I32 numtype = looks_like_number(sv);
1824 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1825 return Atol(SvPVX(sv));
1828 if (ckWARN(WARN_NUMERIC))
1831 d = Atof(SvPVX(sv));
1836 S_asUV(pTHX_ SV *sv)
1838 I32 numtype = looks_like_number(sv);
1841 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1842 return Strtoul(SvPVX(sv), Null(char**), 10);
1846 if (ckWARN(WARN_NUMERIC))
1849 return U_V(Atof(SvPVX(sv)));
1853 * Returns a combination of (advisory only - can get false negatives)
1854 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1856 * 0 if does not look like number.
1858 * In fact possible values are 0 and
1859 * IS_NUMBER_TO_INT_BY_ATOL 123
1860 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1861 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1862 * with a possible addition of IS_NUMBER_NEG.
1866 Perl_looks_like_number(pTHX_ SV *sv)
1869 register char *send;
1870 register char *sbegin;
1871 register char *nbegin;
1879 else if (SvPOKp(sv))
1880 sbegin = SvPV(sv, len);
1883 send = sbegin + len;
1890 numtype = IS_NUMBER_NEG;
1897 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1898 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1902 /* next must be digit or the radix separator */
1906 } while (isDIGIT(*s));
1908 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1909 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1911 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1914 #ifdef USE_LOCALE_NUMERIC
1915 || IS_NUMERIC_RADIX(*s)
1919 numtype |= IS_NUMBER_NOT_IV;
1920 while (isDIGIT(*s)) /* optional digits after the radix */
1925 #ifdef USE_LOCALE_NUMERIC
1926 || IS_NUMERIC_RADIX(*s)
1930 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1931 /* no digits before the radix means we need digits after it */
1935 } while (isDIGIT(*s));
1943 /* we can have an optional exponent part */
1944 if (*s == 'e' || *s == 'E') {
1945 numtype &= ~IS_NUMBER_NEG;
1946 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1948 if (*s == '+' || *s == '-')
1953 } while (isDIGIT(*s));
1962 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1963 return IS_NUMBER_TO_INT_BY_ATOL;
1968 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1971 return sv_2pv(sv, &n_a);
1974 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1976 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1979 char *ptr = buf + TYPE_CHARS(UV);
1994 *--ptr = '0' + (uv % 10);
2003 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2008 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2009 char *tmpbuf = tbuf;
2015 if (SvGMAGICAL(sv)) {
2023 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2025 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2030 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2035 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2037 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2038 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
2044 if (SvTHINKFIRST(sv)) {
2047 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2048 return SvPV(tmpstr,*lp);
2055 switch (SvTYPE(sv)) {
2057 if ( ((SvFLAGS(sv) &
2058 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2059 == (SVs_OBJECT|SVs_RMG))
2060 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2061 && (mg = mg_find(sv, 'r'))) {
2063 regexp *re = (regexp *)mg->mg_obj;
2066 char *fptr = "msix";
2071 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2073 while(ch = *fptr++) {
2075 reflags[left++] = ch;
2078 reflags[right--] = ch;
2083 reflags[left] = '-';
2087 mg->mg_len = re->prelen + 4 + left;
2088 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2089 Copy("(?", mg->mg_ptr, 2, char);
2090 Copy(reflags, mg->mg_ptr+2, left, char);
2091 Copy(":", mg->mg_ptr+left+2, 1, char);
2092 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2093 mg->mg_ptr[mg->mg_len - 1] = ')';
2094 mg->mg_ptr[mg->mg_len] = 0;
2096 PL_reginterp_cnt += re->program[0].next_off;
2108 case SVt_PVBM: s = "SCALAR"; break;
2109 case SVt_PVLV: s = "LVALUE"; break;
2110 case SVt_PVAV: s = "ARRAY"; break;
2111 case SVt_PVHV: s = "HASH"; break;
2112 case SVt_PVCV: s = "CODE"; break;
2113 case SVt_PVGV: s = "GLOB"; break;
2114 case SVt_PVFM: s = "FORMAT"; break;
2115 case SVt_PVIO: s = "IO"; break;
2116 default: s = "UNKNOWN"; break;
2120 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2123 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2129 if (SvREADONLY(sv) && !SvOK(sv)) {
2131 if (ckWARN(WARN_UNINITIALIZED))
2132 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
2137 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2138 /* XXXX 64-bit? IV may have better precision... */
2139 /* I tried changing this for to be 64-bit-aware and
2140 * the t/op/numconvert.t became very, very, angry.
2142 if (SvTYPE(sv) < SVt_PVNV)
2143 sv_upgrade(sv, SVt_PVNV);
2146 olderrno = errno; /* some Xenix systems wipe out errno here */
2148 if (SvNVX(sv) == 0.0)
2149 (void)strcpy(s,"0");
2153 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2156 #ifdef FIXNEGATIVEZERO
2157 if (*s == '-' && s[1] == '0' && !s[2])
2166 else if (SvIOKp(sv)) {
2167 U32 isIOK = SvIOK(sv);
2168 U32 isUIOK = SvIsUV(sv);
2169 char buf[TYPE_CHARS(UV)];
2172 if (SvTYPE(sv) < SVt_PVIV)
2173 sv_upgrade(sv, SVt_PVIV);
2175 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2177 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2178 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2179 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2180 SvCUR_set(sv, ebuf - ptr);
2193 if (ckWARN(WARN_UNINITIALIZED)
2194 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2196 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit);
2199 if (SvTYPE(sv) < SVt_PV)
2200 /* Typically the caller expects that sv_any is not NULL now. */
2201 sv_upgrade(sv, SVt_PV);
2204 *lp = s - SvPVX(sv);
2207 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2208 PTR2UV(sv),SvPVX(sv)));
2212 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2213 /* Sneaky stuff here */
2217 tsv = newSVpv(tmpbuf, 0);
2233 len = strlen(tmpbuf);
2235 #ifdef FIXNEGATIVEZERO
2236 if (len == 2 && t[0] == '-' && t[1] == '0') {
2241 (void)SvUPGRADE(sv, SVt_PV);
2243 s = SvGROW(sv, len + 1);
2251 /* This function is only called on magical items */
2253 Perl_sv_2bool(pTHX_ register SV *sv)
2263 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2264 return SvTRUE(tmpsv);
2265 return SvRV(sv) != 0;
2268 register XPV* Xpvtmp;
2269 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2270 (*Xpvtmp->xpv_pv > '0' ||
2271 Xpvtmp->xpv_cur > 1 ||
2272 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2279 return SvIVX(sv) != 0;
2282 return SvNVX(sv) != 0.0;
2289 /* Note: sv_setsv() should not be called with a source string that needs
2290 * to be reused, since it may destroy the source string if it is marked
2295 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2298 register U32 sflags;
2304 SV_CHECK_THINKFIRST(dstr);
2306 sstr = &PL_sv_undef;
2307 stype = SvTYPE(sstr);
2308 dtype = SvTYPE(dstr);
2312 /* There's a lot of redundancy below but we're going for speed here */
2317 if (dtype != SVt_PVGV) {
2318 (void)SvOK_off(dstr);
2326 sv_upgrade(dstr, SVt_IV);
2329 sv_upgrade(dstr, SVt_PVNV);
2333 sv_upgrade(dstr, SVt_PVIV);
2336 (void)SvIOK_only(dstr);
2337 SvIVX(dstr) = SvIVX(sstr);
2350 sv_upgrade(dstr, SVt_NV);
2355 sv_upgrade(dstr, SVt_PVNV);
2358 SvNVX(dstr) = SvNVX(sstr);
2359 (void)SvNOK_only(dstr);
2367 sv_upgrade(dstr, SVt_RV);
2368 else if (dtype == SVt_PVGV &&
2369 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2372 if (PL_curcop->cop_stash != GvSTASH(dstr))
2373 GvIMPORTED_on(dstr);
2383 sv_upgrade(dstr, SVt_PV);
2386 if (dtype < SVt_PVIV)
2387 sv_upgrade(dstr, SVt_PVIV);
2390 if (dtype < SVt_PVNV)
2391 sv_upgrade(dstr, SVt_PVNV);
2398 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2399 PL_op_name[PL_op->op_type]);
2401 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2405 if (dtype <= SVt_PVGV) {
2407 if (dtype != SVt_PVGV) {
2408 char *name = GvNAME(sstr);
2409 STRLEN len = GvNAMELEN(sstr);
2410 sv_upgrade(dstr, SVt_PVGV);
2411 sv_magic(dstr, dstr, '*', name, len);
2412 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2413 GvNAME(dstr) = savepvn(name, len);
2414 GvNAMELEN(dstr) = len;
2415 SvFAKE_on(dstr); /* can coerce to non-glob */
2417 /* ahem, death to those who redefine active sort subs */
2418 else if (PL_curstackinfo->si_type == PERLSI_SORT
2419 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2420 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2422 (void)SvOK_off(dstr);
2423 GvINTRO_off(dstr); /* one-shot flag */
2425 GvGP(dstr) = gp_ref(GvGP(sstr));
2427 if (PL_curcop->cop_stash != GvSTASH(dstr))
2428 GvIMPORTED_on(dstr);
2435 if (SvGMAGICAL(sstr)) {
2437 if (SvTYPE(sstr) != stype) {
2438 stype = SvTYPE(sstr);
2439 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2443 if (stype == SVt_PVLV)
2444 (void)SvUPGRADE(dstr, SVt_PVNV);
2446 (void)SvUPGRADE(dstr, stype);
2449 sflags = SvFLAGS(sstr);
2451 if (sflags & SVf_ROK) {
2452 if (dtype >= SVt_PV) {
2453 if (dtype == SVt_PVGV) {
2454 SV *sref = SvREFCNT_inc(SvRV(sstr));
2456 int intro = GvINTRO(dstr);
2460 GvGP(dstr)->gp_refcnt--;
2461 GvINTRO_off(dstr); /* one-shot flag */
2462 Newz(602,gp, 1, GP);
2463 GvGP(dstr) = gp_ref(gp);
2464 GvSV(dstr) = NEWSV(72,0);
2465 GvLINE(dstr) = PL_curcop->cop_line;
2466 GvEGV(dstr) = (GV*)dstr;
2469 switch (SvTYPE(sref)) {
2472 SAVESPTR(GvAV(dstr));
2474 dref = (SV*)GvAV(dstr);
2475 GvAV(dstr) = (AV*)sref;
2476 if (PL_curcop->cop_stash != GvSTASH(dstr))
2477 GvIMPORTED_AV_on(dstr);
2481 SAVESPTR(GvHV(dstr));
2483 dref = (SV*)GvHV(dstr);
2484 GvHV(dstr) = (HV*)sref;
2485 if (PL_curcop->cop_stash != GvSTASH(dstr))
2486 GvIMPORTED_HV_on(dstr);
2490 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2491 SvREFCNT_dec(GvCV(dstr));
2492 GvCV(dstr) = Nullcv;
2493 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2494 PL_sub_generation++;
2496 SAVESPTR(GvCV(dstr));
2499 dref = (SV*)GvCV(dstr);
2500 if (GvCV(dstr) != (CV*)sref) {
2501 CV* cv = GvCV(dstr);
2503 if (!GvCVGEN((GV*)dstr) &&
2504 (CvROOT(cv) || CvXSUB(cv)))
2506 SV *const_sv = cv_const_sv(cv);
2507 bool const_changed = TRUE;
2509 const_changed = sv_cmp(const_sv,
2510 op_const_sv(CvSTART((CV*)sref),
2512 /* ahem, death to those who redefine
2513 * active sort subs */
2514 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2515 PL_sortcop == CvSTART(cv))
2517 "Can't redefine active sort subroutine %s",
2518 GvENAME((GV*)dstr));
2519 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2520 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2521 && HvNAME(GvSTASH(CvGV(cv)))
2522 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2524 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2525 "Constant subroutine %s redefined"
2526 : "Subroutine %s redefined",
2527 GvENAME((GV*)dstr));
2530 cv_ckproto(cv, (GV*)dstr,
2531 SvPOK(sref) ? SvPVX(sref) : Nullch);
2533 GvCV(dstr) = (CV*)sref;
2534 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2535 GvASSUMECV_on(dstr);
2536 PL_sub_generation++;
2538 if (PL_curcop->cop_stash != GvSTASH(dstr))
2539 GvIMPORTED_CV_on(dstr);
2543 SAVESPTR(GvIOp(dstr));
2545 dref = (SV*)GvIOp(dstr);
2546 GvIOp(dstr) = (IO*)sref;
2550 SAVESPTR(GvSV(dstr));
2552 dref = (SV*)GvSV(dstr);
2554 if (PL_curcop->cop_stash != GvSTASH(dstr))
2555 GvIMPORTED_SV_on(dstr);
2566 (void)SvOOK_off(dstr); /* backoff */
2568 Safefree(SvPVX(dstr));
2569 SvLEN(dstr)=SvCUR(dstr)=0;
2572 (void)SvOK_off(dstr);
2573 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2575 if (sflags & SVp_NOK) {
2577 SvNVX(dstr) = SvNVX(sstr);
2579 if (sflags & SVp_IOK) {
2580 (void)SvIOK_on(dstr);
2581 SvIVX(dstr) = SvIVX(sstr);
2585 if (SvAMAGIC(sstr)) {
2589 else if (sflags & SVp_POK) {
2592 * Check to see if we can just swipe the string. If so, it's a
2593 * possible small lose on short strings, but a big win on long ones.
2594 * It might even be a win on short strings if SvPVX(dstr)
2595 * has to be allocated and SvPVX(sstr) has to be freed.
2598 if (SvTEMP(sstr) && /* slated for free anyway? */
2599 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2600 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2602 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2604 SvFLAGS(dstr) &= ~SVf_OOK;
2605 Safefree(SvPVX(dstr) - SvIVX(dstr));
2607 else if (SvLEN(dstr))
2608 Safefree(SvPVX(dstr));
2610 (void)SvPOK_only(dstr);
2611 SvPV_set(dstr, SvPVX(sstr));
2612 SvLEN_set(dstr, SvLEN(sstr));
2613 SvCUR_set(dstr, SvCUR(sstr));
2615 (void)SvOK_off(sstr);
2616 SvPV_set(sstr, Nullch);
2621 else { /* have to copy actual string */
2622 STRLEN len = SvCUR(sstr);
2624 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2625 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2626 SvCUR_set(dstr, len);
2627 *SvEND(dstr) = '\0';
2628 (void)SvPOK_only(dstr);
2631 if (sflags & SVp_NOK) {
2633 SvNVX(dstr) = SvNVX(sstr);
2635 if (sflags & SVp_IOK) {
2636 (void)SvIOK_on(dstr);
2637 SvIVX(dstr) = SvIVX(sstr);
2642 else if (sflags & SVp_NOK) {
2643 SvNVX(dstr) = SvNVX(sstr);
2644 (void)SvNOK_only(dstr);
2646 (void)SvIOK_on(dstr);
2647 SvIVX(dstr) = SvIVX(sstr);
2648 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2653 else if (sflags & SVp_IOK) {
2654 (void)SvIOK_only(dstr);
2655 SvIVX(dstr) = SvIVX(sstr);
2660 if (dtype == SVt_PVGV) {
2661 if (ckWARN(WARN_UNSAFE))
2662 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2665 (void)SvOK_off(dstr);
2671 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2673 sv_setsv(dstr,sstr);
2678 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2680 register char *dptr;
2681 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2682 elicit a warning, but it won't hurt. */
2683 SV_CHECK_THINKFIRST(sv);
2688 (void)SvUPGRADE(sv, SVt_PV);
2690 SvGROW(sv, len + 1);
2692 Move(ptr,dptr,len,char);
2695 (void)SvPOK_only(sv); /* validate pointer */
2700 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2702 sv_setpvn(sv,ptr,len);
2707 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2709 register STRLEN len;
2711 SV_CHECK_THINKFIRST(sv);
2717 (void)SvUPGRADE(sv, SVt_PV);
2719 SvGROW(sv, len + 1);
2720 Move(ptr,SvPVX(sv),len+1,char);
2722 (void)SvPOK_only(sv); /* validate pointer */
2727 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2734 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2736 SV_CHECK_THINKFIRST(sv);
2737 (void)SvUPGRADE(sv, SVt_PV);
2742 (void)SvOOK_off(sv);
2743 if (SvPVX(sv) && SvLEN(sv))
2744 Safefree(SvPVX(sv));
2745 Renew(ptr, len+1, char);
2748 SvLEN_set(sv, len+1);
2750 (void)SvPOK_only(sv); /* validate pointer */
2755 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2757 sv_usepvn(sv,ptr,len);
2762 Perl_sv_force_normal(pTHX_ register SV *sv)
2764 if (SvREADONLY(sv)) {
2766 if (PL_curcop != &PL_compiling)
2767 Perl_croak(aTHX_ PL_no_modify);
2771 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2776 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2780 register STRLEN delta;
2782 if (!ptr || !SvPOKp(sv))
2784 SV_CHECK_THINKFIRST(sv);
2785 if (SvTYPE(sv) < SVt_PVIV)
2786 sv_upgrade(sv,SVt_PVIV);
2789 if (!SvLEN(sv)) { /* make copy of shared string */
2790 char *pvx = SvPVX(sv);
2791 STRLEN len = SvCUR(sv);
2792 SvGROW(sv, len + 1);
2793 Move(pvx,SvPVX(sv),len,char);
2797 SvFLAGS(sv) |= SVf_OOK;
2799 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2800 delta = ptr - SvPVX(sv);
2808 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2813 junk = SvPV_force(sv, tlen);
2814 SvGROW(sv, tlen + len + 1);
2817 Move(ptr,SvPVX(sv)+tlen,len,char);
2820 (void)SvPOK_only(sv); /* validate pointer */
2825 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2827 sv_catpvn(sv,ptr,len);
2832 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2838 if (s = SvPV(sstr, len))
2839 sv_catpvn(dstr,s,len);
2843 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2845 sv_catsv(dstr,sstr);
2850 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2852 register STRLEN len;
2858 junk = SvPV_force(sv, tlen);
2860 SvGROW(sv, tlen + len + 1);
2863 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2865 (void)SvPOK_only(sv); /* validate pointer */
2870 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2877 Perl_newSV(pTHX_ STRLEN len)
2883 sv_upgrade(sv, SVt_PV);
2884 SvGROW(sv, len + 1);
2889 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2892 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2896 if (SvREADONLY(sv)) {
2898 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2899 Perl_croak(aTHX_ PL_no_modify);
2901 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2902 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2909 (void)SvUPGRADE(sv, SVt_PVMG);
2911 Newz(702,mg, 1, MAGIC);
2912 mg->mg_moremagic = SvMAGIC(sv);
2915 if (!obj || obj == sv || how == '#' || how == 'r')
2919 mg->mg_obj = SvREFCNT_inc(obj);
2920 mg->mg_flags |= MGf_REFCOUNTED;
2923 mg->mg_len = namlen;
2926 mg->mg_ptr = savepvn(name, namlen);
2927 else if (namlen == HEf_SVKEY)
2928 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2932 mg->mg_virtual = &PL_vtbl_sv;
2935 mg->mg_virtual = &PL_vtbl_amagic;
2938 mg->mg_virtual = &PL_vtbl_amagicelem;
2944 mg->mg_virtual = &PL_vtbl_bm;
2947 mg->mg_virtual = &PL_vtbl_regdata;
2950 mg->mg_virtual = &PL_vtbl_regdatum;
2953 mg->mg_virtual = &PL_vtbl_env;
2956 mg->mg_virtual = &PL_vtbl_fm;
2959 mg->mg_virtual = &PL_vtbl_envelem;
2962 mg->mg_virtual = &PL_vtbl_mglob;
2965 mg->mg_virtual = &PL_vtbl_isa;
2968 mg->mg_virtual = &PL_vtbl_isaelem;
2971 mg->mg_virtual = &PL_vtbl_nkeys;
2978 mg->mg_virtual = &PL_vtbl_dbline;
2982 mg->mg_virtual = &PL_vtbl_mutex;
2984 #endif /* USE_THREADS */
2985 #ifdef USE_LOCALE_COLLATE
2987 mg->mg_virtual = &PL_vtbl_collxfrm;
2989 #endif /* USE_LOCALE_COLLATE */
2991 mg->mg_virtual = &PL_vtbl_pack;
2995 mg->mg_virtual = &PL_vtbl_packelem;
2998 mg->mg_virtual = &PL_vtbl_regexp;
3001 mg->mg_virtual = &PL_vtbl_sig;
3004 mg->mg_virtual = &PL_vtbl_sigelem;
3007 mg->mg_virtual = &PL_vtbl_taint;
3011 mg->mg_virtual = &PL_vtbl_uvar;
3014 mg->mg_virtual = &PL_vtbl_vec;
3017 mg->mg_virtual = &PL_vtbl_substr;
3020 mg->mg_virtual = &PL_vtbl_defelem;
3023 mg->mg_virtual = &PL_vtbl_glob;
3026 mg->mg_virtual = &PL_vtbl_arylen;
3029 mg->mg_virtual = &PL_vtbl_pos;
3032 mg->mg_virtual = &PL_vtbl_backref;
3034 case '~': /* Reserved for use by extensions not perl internals. */
3035 /* Useful for attaching extension internal data to perl vars. */
3036 /* Note that multiple extensions may clash if magical scalars */
3037 /* etc holding private data from one are passed to another. */
3041 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3045 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3049 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3053 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3056 for (mg = *mgp; mg; mg = *mgp) {
3057 if (mg->mg_type == type) {
3058 MGVTBL* vtbl = mg->mg_virtual;
3059 *mgp = mg->mg_moremagic;
3060 if (vtbl && (vtbl->svt_free != NULL))
3061 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3062 if (mg->mg_ptr && mg->mg_type != 'g')
3063 if (mg->mg_len >= 0)
3064 Safefree(mg->mg_ptr);
3065 else if (mg->mg_len == HEf_SVKEY)
3066 SvREFCNT_dec((SV*)mg->mg_ptr);
3067 if (mg->mg_flags & MGf_REFCOUNTED)
3068 SvREFCNT_dec(mg->mg_obj);
3072 mgp = &mg->mg_moremagic;
3076 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3083 Perl_sv_rvweaken(pTHX_ SV *sv)
3086 if (!SvOK(sv)) /* let undefs pass */
3089 Perl_croak(aTHX_ "Can't weaken a nonreference");
3090 else if (SvWEAKREF(sv)) {
3092 if (ckWARN(WARN_MISC))
3093 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3097 sv_add_backref(tsv, sv);
3104 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3108 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3109 av = (AV*)mg->mg_obj;
3112 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3113 SvREFCNT_dec(av); /* for sv_magic */
3119 S_sv_del_backref(pTHX_ SV *sv)
3126 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3127 Perl_croak(aTHX_ "panic: del_backref");
3128 av = (AV *)mg->mg_obj;
3133 svp[i] = &PL_sv_undef; /* XXX */
3140 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3144 register char *midend;
3145 register char *bigend;
3151 Perl_croak(aTHX_ "Can't modify non-existent substring");
3152 SvPV_force(bigstr, curlen);
3153 if (offset + len > curlen) {
3154 SvGROW(bigstr, offset+len+1);
3155 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3156 SvCUR_set(bigstr, offset+len);
3159 i = littlelen - len;
3160 if (i > 0) { /* string might grow */
3161 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3162 mid = big + offset + len;
3163 midend = bigend = big + SvCUR(bigstr);
3166 while (midend > mid) /* shove everything down */
3167 *--bigend = *--midend;
3168 Move(little,big+offset,littlelen,char);
3174 Move(little,SvPVX(bigstr)+offset,len,char);
3179 big = SvPVX(bigstr);
3182 bigend = big + SvCUR(bigstr);
3184 if (midend > bigend)
3185 Perl_croak(aTHX_ "panic: sv_insert");
3187 if (mid - big > bigend - midend) { /* faster to shorten from end */
3189 Move(little, mid, littlelen,char);
3192 i = bigend - midend;
3194 Move(midend, mid, i,char);
3198 SvCUR_set(bigstr, mid - big);
3201 else if (i = mid - big) { /* faster from front */
3202 midend -= littlelen;
3204 sv_chop(bigstr,midend-i);
3209 Move(little, mid, littlelen,char);
3211 else if (littlelen) {
3212 midend -= littlelen;
3213 sv_chop(bigstr,midend);
3214 Move(little,midend,littlelen,char);
3217 sv_chop(bigstr,midend);
3222 /* make sv point to what nstr did */
3225 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3228 U32 refcnt = SvREFCNT(sv);
3229 SV_CHECK_THINKFIRST(sv);
3230 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3231 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3232 if (SvMAGICAL(sv)) {
3236 sv_upgrade(nsv, SVt_PVMG);
3237 SvMAGIC(nsv) = SvMAGIC(sv);
3238 SvFLAGS(nsv) |= SvMAGICAL(sv);
3244 assert(!SvREFCNT(sv));
3245 StructCopy(nsv,sv,SV);
3246 SvREFCNT(sv) = refcnt;
3247 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3252 Perl_sv_clear(pTHX_ register SV *sv)
3256 assert(SvREFCNT(sv) == 0);
3260 if (PL_defstash) { /* Still have a symbol table? */
3265 Zero(&tmpref, 1, SV);
3266 sv_upgrade(&tmpref, SVt_RV);
3268 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3269 SvREFCNT(&tmpref) = 1;
3272 stash = SvSTASH(sv);
3273 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3276 PUSHSTACKi(PERLSI_DESTROY);
3277 SvRV(&tmpref) = SvREFCNT_inc(sv);
3282 call_sv((SV*)GvCV(destructor),
3283 G_DISCARD|G_EVAL|G_KEEPERR);
3289 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3291 del_XRV(SvANY(&tmpref));
3294 if (PL_in_clean_objs)
3295 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3297 /* DESTROY gave object new lease on life */
3303 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3304 SvOBJECT_off(sv); /* Curse the object. */
3305 if (SvTYPE(sv) != SVt_PVIO)
3306 --PL_sv_objcount; /* XXX Might want something more general */
3309 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3312 switch (SvTYPE(sv)) {
3315 IoIFP(sv) != PerlIO_stdin() &&
3316 IoIFP(sv) != PerlIO_stdout() &&
3317 IoIFP(sv) != PerlIO_stderr())
3319 io_close((IO*)sv, FALSE);
3322 PerlDir_close(IoDIRP(sv));
3325 Safefree(IoTOP_NAME(sv));
3326 Safefree(IoFMT_NAME(sv));
3327 Safefree(IoBOTTOM_NAME(sv));
3342 SvREFCNT_dec(LvTARG(sv));
3346 Safefree(GvNAME(sv));
3347 /* cannot decrease stash refcount yet, as we might recursively delete
3348 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3349 of stash until current sv is completely gone.
3350 -- JohnPC, 27 Mar 1998 */
3351 stash = GvSTASH(sv);
3357 (void)SvOOK_off(sv);
3365 SvREFCNT_dec(SvRV(sv));
3367 else if (SvPVX(sv) && SvLEN(sv))
3368 Safefree(SvPVX(sv));
3378 switch (SvTYPE(sv)) {
3394 del_XPVIV(SvANY(sv));
3397 del_XPVNV(SvANY(sv));
3400 del_XPVMG(SvANY(sv));
3403 del_XPVLV(SvANY(sv));
3406 del_XPVAV(SvANY(sv));
3409 del_XPVHV(SvANY(sv));
3412 del_XPVCV(SvANY(sv));
3415 del_XPVGV(SvANY(sv));
3416 /* code duplication for increased performance. */
3417 SvFLAGS(sv) &= SVf_BREAK;
3418 SvFLAGS(sv) |= SVTYPEMASK;
3419 /* decrease refcount of the stash that owns this GV, if any */
3421 SvREFCNT_dec(stash);
3422 return; /* not break, SvFLAGS reset already happened */
3424 del_XPVBM(SvANY(sv));
3427 del_XPVFM(SvANY(sv));
3430 del_XPVIO(SvANY(sv));
3433 SvFLAGS(sv) &= SVf_BREAK;
3434 SvFLAGS(sv) |= SVTYPEMASK;
3438 Perl_sv_newref(pTHX_ SV *sv)
3441 ATOMIC_INC(SvREFCNT(sv));
3446 Perl_sv_free(pTHX_ SV *sv)
3449 int refcount_is_zero;
3453 if (SvREFCNT(sv) == 0) {
3454 if (SvFLAGS(sv) & SVf_BREAK)
3456 if (PL_in_clean_all) /* All is fair */
3458 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3459 /* make sure SvREFCNT(sv)==0 happens very seldom */
3460 SvREFCNT(sv) = (~(U32)0)/2;
3463 if (ckWARN_d(WARN_INTERNAL))
3464 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3467 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3468 if (!refcount_is_zero)
3472 if (ckWARN_d(WARN_DEBUGGING))
3473 Perl_warner(aTHX_ WARN_DEBUGGING,
3474 "Attempt to free temp prematurely: SV 0x%"UVxf,
3479 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3480 /* make sure SvREFCNT(sv)==0 happens very seldom */
3481 SvREFCNT(sv) = (~(U32)0)/2;
3490 Perl_sv_len(pTHX_ register SV *sv)
3499 len = mg_length(sv);
3501 junk = SvPV(sv, len);
3506 Perl_sv_len_utf8(pTHX_ register SV *sv)
3517 len = mg_length(sv);
3520 s = (U8*)SvPV(sv, len);
3531 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3536 I32 uoffset = *offsetp;
3542 start = s = (U8*)SvPV(sv, len);
3544 while (s < send && uoffset--)
3548 *offsetp = s - start;
3552 while (s < send && ulen--)
3562 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3571 s = (U8*)SvPV(sv, len);
3573 Perl_croak(aTHX_ "panic: bad byte offset");
3574 send = s + *offsetp;
3582 if (ckWARN_d(WARN_UTF8))
3583 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3591 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3603 pv1 = SvPV(str1, cur1);
3608 pv2 = SvPV(str2, cur2);
3613 return memEQ(pv1, pv2, cur1);
3617 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3620 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3622 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3626 return cur2 ? -1 : 0;
3631 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3634 return retval < 0 ? -1 : 1;
3639 return cur1 < cur2 ? -1 : 1;
3643 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3645 #ifdef USE_LOCALE_COLLATE
3651 if (PL_collation_standard)
3655 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3657 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3659 if (!pv1 || !len1) {
3670 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3673 return retval < 0 ? -1 : 1;
3676 * When the result of collation is equality, that doesn't mean
3677 * that there are no differences -- some locales exclude some
3678 * characters from consideration. So to avoid false equalities,
3679 * we use the raw string as a tiebreaker.
3685 #endif /* USE_LOCALE_COLLATE */
3687 return sv_cmp(sv1, sv2);
3690 #ifdef USE_LOCALE_COLLATE
3692 * Any scalar variable may carry an 'o' magic that contains the
3693 * scalar data of the variable transformed to such a format that
3694 * a normal memory comparison can be used to compare the data
3695 * according to the locale settings.
3698 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3702 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3703 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3708 Safefree(mg->mg_ptr);
3710 if ((xf = mem_collxfrm(s, len, &xlen))) {
3711 if (SvREADONLY(sv)) {
3714 return xf + sizeof(PL_collation_ix);
3717 sv_magic(sv, 0, 'o', 0, 0);
3718 mg = mg_find(sv, 'o');
3731 if (mg && mg->mg_ptr) {
3733 return mg->mg_ptr + sizeof(PL_collation_ix);
3741 #endif /* USE_LOCALE_COLLATE */
3744 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3749 register STDCHAR rslast;
3750 register STDCHAR *bp;
3754 SV_CHECK_THINKFIRST(sv);
3755 (void)SvUPGRADE(sv, SVt_PV);
3759 if (RsSNARF(PL_rs)) {
3763 else if (RsRECORD(PL_rs)) {
3764 I32 recsize, bytesread;
3767 /* Grab the size of the record we're getting */
3768 recsize = SvIV(SvRV(PL_rs));
3769 (void)SvPOK_only(sv); /* Validate pointer */
3770 buffer = SvGROW(sv, recsize + 1);
3773 /* VMS wants read instead of fread, because fread doesn't respect */
3774 /* RMS record boundaries. This is not necessarily a good thing to be */
3775 /* doing, but we've got no other real choice */
3776 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3778 bytesread = PerlIO_read(fp, buffer, recsize);
3780 SvCUR_set(sv, bytesread);
3781 buffer[bytesread] = '\0';
3782 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3784 else if (RsPARA(PL_rs)) {
3789 rsptr = SvPV(PL_rs, rslen);
3790 rslast = rslen ? rsptr[rslen - 1] : '\0';
3792 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3793 do { /* to make sure file boundaries work right */
3796 i = PerlIO_getc(fp);
3800 PerlIO_ungetc(fp,i);
3806 /* See if we know enough about I/O mechanism to cheat it ! */
3808 /* This used to be #ifdef test - it is made run-time test for ease
3809 of abstracting out stdio interface. One call should be cheap
3810 enough here - and may even be a macro allowing compile
3814 if (PerlIO_fast_gets(fp)) {
3817 * We're going to steal some values from the stdio struct
3818 * and put EVERYTHING in the innermost loop into registers.
3820 register STDCHAR *ptr;
3824 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3825 /* An ungetc()d char is handled separately from the regular
3826 * buffer, so we getc() it back out and stuff it in the buffer.
3828 i = PerlIO_getc(fp);
3829 if (i == EOF) return 0;
3830 *(--((*fp)->_ptr)) = (unsigned char) i;
3834 /* Here is some breathtakingly efficient cheating */
3836 cnt = PerlIO_get_cnt(fp); /* get count into register */
3837 (void)SvPOK_only(sv); /* validate pointer */
3838 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3839 if (cnt > 80 && SvLEN(sv) > append) {
3840 shortbuffered = cnt - SvLEN(sv) + append + 1;
3841 cnt -= shortbuffered;
3845 /* remember that cnt can be negative */
3846 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3851 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3852 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3853 DEBUG_P(PerlIO_printf(Perl_debug_log,
3854 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3855 DEBUG_P(PerlIO_printf(Perl_debug_log,
3856 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3857 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3858 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3863 while (cnt > 0) { /* this | eat */
3865 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3866 goto thats_all_folks; /* screams | sed :-) */
3870 Copy(ptr, bp, cnt, char); /* this | eat */
3871 bp += cnt; /* screams | dust */
3872 ptr += cnt; /* louder | sed :-) */
3877 if (shortbuffered) { /* oh well, must extend */
3878 cnt = shortbuffered;
3880 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3882 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3883 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3887 DEBUG_P(PerlIO_printf(Perl_debug_log,
3888 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
3889 PTR2UV(ptr),(long)cnt));
3890 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3891 DEBUG_P(PerlIO_printf(Perl_debug_log,
3892 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3893 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3894 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3895 /* This used to call 'filbuf' in stdio form, but as that behaves like
3896 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3897 another abstraction. */
3898 i = PerlIO_getc(fp); /* get more characters */
3899 DEBUG_P(PerlIO_printf(Perl_debug_log,
3900 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3901 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3902 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3903 cnt = PerlIO_get_cnt(fp);
3904 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3905 DEBUG_P(PerlIO_printf(Perl_debug_log,
3906 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3908 if (i == EOF) /* all done for ever? */
3909 goto thats_really_all_folks;
3911 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3913 SvGROW(sv, bpx + cnt + 2);
3914 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3916 *bp++ = i; /* store character from PerlIO_getc */
3918 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3919 goto thats_all_folks;
3923 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3924 memNE((char*)bp - rslen, rsptr, rslen))
3925 goto screamer; /* go back to the fray */
3926 thats_really_all_folks:
3928 cnt += shortbuffered;
3929 DEBUG_P(PerlIO_printf(Perl_debug_log,
3930 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3931 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3932 DEBUG_P(PerlIO_printf(Perl_debug_log,
3933 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3934 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3935 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3937 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3938 DEBUG_P(PerlIO_printf(Perl_debug_log,
3939 "Screamer: done, len=%ld, string=|%.*s|\n",
3940 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3945 /*The big, slow, and stupid way */
3948 /* Need to work around EPOC SDK features */
3949 /* On WINS: MS VC5 generates calls to _chkstk, */
3950 /* if a `large' stack frame is allocated */
3951 /* gcc on MARM does not generate calls like these */
3957 register STDCHAR *bpe = buf + sizeof(buf);
3959 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3960 ; /* keep reading */
3964 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3965 /* Accomodate broken VAXC compiler, which applies U8 cast to
3966 * both args of ?: operator, causing EOF to change into 255
3968 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3972 sv_catpvn(sv, (char *) buf, cnt);
3974 sv_setpvn(sv, (char *) buf, cnt);
3976 if (i != EOF && /* joy */
3978 SvCUR(sv) < rslen ||
3979 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
3983 * If we're reading from a TTY and we get a short read,
3984 * indicating that the user hit his EOF character, we need
3985 * to notice it now, because if we try to read from the TTY
3986 * again, the EOF condition will disappear.
3988 * The comparison of cnt to sizeof(buf) is an optimization
3989 * that prevents unnecessary calls to feof().
3993 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
3998 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3999 while (i != EOF) { /* to make sure file boundaries work right */
4000 i = PerlIO_getc(fp);
4002 PerlIO_ungetc(fp,i);
4009 win32_strip_return(sv);
4012 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4017 Perl_sv_inc(pTHX_ register SV *sv)
4026 if (SvTHINKFIRST(sv)) {
4027 if (SvREADONLY(sv)) {
4029 if (PL_curcop != &PL_compiling)
4030 Perl_croak(aTHX_ PL_no_modify);
4034 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4036 i = PTR2IV(SvRV(sv));
4041 flags = SvFLAGS(sv);
4042 if (flags & SVp_NOK) {
4043 (void)SvNOK_only(sv);
4047 if (flags & SVp_IOK) {
4049 if (SvUVX(sv) == UV_MAX)
4050 sv_setnv(sv, (NV)UV_MAX + 1.0);
4052 (void)SvIOK_only_UV(sv);
4055 if (SvIVX(sv) == IV_MAX)
4056 sv_setnv(sv, (NV)IV_MAX + 1.0);
4058 (void)SvIOK_only(sv);
4064 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4065 if ((flags & SVTYPEMASK) < SVt_PVNV)
4066 sv_upgrade(sv, SVt_NV);
4068 (void)SvNOK_only(sv);
4072 while (isALPHA(*d)) d++;
4073 while (isDIGIT(*d)) d++;
4075 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4079 while (d >= SvPVX(sv)) {
4087 /* MKS: The original code here died if letters weren't consecutive.
4088 * at least it didn't have to worry about non-C locales. The
4089 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4090 * arranged in order (although not consecutively) and that only
4091 * [A-Za-z] are accepted by isALPHA in the C locale.
4093 if (*d != 'z' && *d != 'Z') {
4094 do { ++*d; } while (!isALPHA(*d));
4097 *(d--) -= 'z' - 'a';
4102 *(d--) -= 'z' - 'a' + 1;
4106 /* oh,oh, the number grew */
4107 SvGROW(sv, SvCUR(sv) + 2);
4109 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4118 Perl_sv_dec(pTHX_ register SV *sv)
4126 if (SvTHINKFIRST(sv)) {
4127 if (SvREADONLY(sv)) {
4129 if (PL_curcop != &PL_compiling)
4130 Perl_croak(aTHX_ PL_no_modify);
4134 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4136 i = PTR2IV(SvRV(sv));
4141 flags = SvFLAGS(sv);
4142 if (flags & SVp_NOK) {
4144 (void)SvNOK_only(sv);
4147 if (flags & SVp_IOK) {
4149 if (SvUVX(sv) == 0) {
4150 (void)SvIOK_only(sv);
4154 (void)SvIOK_only_UV(sv);
4158 if (SvIVX(sv) == IV_MIN)
4159 sv_setnv(sv, (NV)IV_MIN - 1.0);
4161 (void)SvIOK_only(sv);
4167 if (!(flags & SVp_POK)) {
4168 if ((flags & SVTYPEMASK) < SVt_PVNV)
4169 sv_upgrade(sv, SVt_NV);
4171 (void)SvNOK_only(sv);
4174 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4177 /* Make a string that will exist for the duration of the expression
4178 * evaluation. Actually, it may have to last longer than that, but
4179 * hopefully we won't free it until it has been assigned to a
4180 * permanent location. */
4183 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4189 sv_setsv(sv,oldstr);
4191 PL_tmps_stack[++PL_tmps_ix] = sv;
4197 Perl_sv_newmortal(pTHX)
4203 SvFLAGS(sv) = SVs_TEMP;
4205 PL_tmps_stack[++PL_tmps_ix] = sv;
4209 /* same thing without the copying */
4212 Perl_sv_2mortal(pTHX_ register SV *sv)
4217 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4220 PL_tmps_stack[++PL_tmps_ix] = sv;
4226 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4233 sv_setpvn(sv,s,len);
4238 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4243 sv_setpvn(sv,s,len);
4247 #if defined(PERL_IMPLICIT_CONTEXT)
4249 Perl_newSVpvf_nocontext(const char* pat, ...)
4254 va_start(args, pat);
4255 sv = vnewSVpvf(pat, &args);
4262 Perl_newSVpvf(pTHX_ const char* pat, ...)
4266 va_start(args, pat);
4267 sv = vnewSVpvf(pat, &args);
4273 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4277 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4282 Perl_newSVnv(pTHX_ NV n)
4292 Perl_newSViv(pTHX_ IV i)
4302 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4308 sv_upgrade(sv, SVt_RV);
4316 Perl_newRV(pTHX_ SV *tmpRef)
4318 return newRV_noinc(SvREFCNT_inc(tmpRef));
4321 /* make an exact duplicate of old */
4324 Perl_newSVsv(pTHX_ register SV *old)
4331 if (SvTYPE(old) == SVTYPEMASK) {
4332 if (ckWARN_d(WARN_INTERNAL))
4333 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4348 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4356 char todo[PERL_UCHAR_MAX+1];
4361 if (!*s) { /* reset ?? searches */
4362 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4363 pm->op_pmdynflags &= ~PMdf_USED;
4368 /* reset variables */
4370 if (!HvARRAY(stash))
4373 Zero(todo, 256, char);
4375 i = (unsigned char)*s;
4379 max = (unsigned char)*s++;
4380 for ( ; i <= max; i++) {
4383 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4384 for (entry = HvARRAY(stash)[i];
4386 entry = HeNEXT(entry))
4388 if (!todo[(U8)*HeKEY(entry)])
4390 gv = (GV*)HeVAL(entry);
4392 if (SvTHINKFIRST(sv)) {
4393 if (!SvREADONLY(sv) && SvROK(sv))
4398 if (SvTYPE(sv) >= SVt_PV) {
4400 if (SvPVX(sv) != Nullch)
4407 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4409 #ifndef VMS /* VMS has no environ array */
4411 environ[0] = Nullch;
4420 Perl_sv_2io(pTHX_ SV *sv)
4426 switch (SvTYPE(sv)) {
4434 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4438 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4440 return sv_2io(SvRV(sv));
4441 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4447 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4454 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4461 return *gvp = Nullgv, Nullcv;
4462 switch (SvTYPE(sv)) {
4482 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4483 tryAMAGICunDEREF(to_cv);
4486 if (SvTYPE(sv) == SVt_PVCV) {
4495 Perl_croak(aTHX_ "Not a subroutine reference");
4500 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4506 if (lref && !GvCVu(gv)) {
4509 tmpsv = NEWSV(704,0);
4510 gv_efullname3(tmpsv, gv, Nullch);
4511 /* XXX this is probably not what they think they're getting.
4512 * It has the same effect as "sub name;", i.e. just a forward
4514 newSUB(start_subparse(FALSE, 0),
4515 newSVOP(OP_CONST, 0, tmpsv),
4520 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4527 Perl_sv_true(pTHX_ register SV *sv)
4534 if ((tXpv = (XPV*)SvANY(sv)) &&
4535 (*tXpv->xpv_pv > '0' ||
4536 tXpv->xpv_cur > 1 ||
4537 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4544 return SvIVX(sv) != 0;
4547 return SvNVX(sv) != 0.0;
4549 return sv_2bool(sv);
4555 Perl_sv_iv(pTHX_ register SV *sv)
4559 return (IV)SvUVX(sv);
4566 Perl_sv_uv(pTHX_ register SV *sv)
4571 return (UV)SvIVX(sv);
4577 Perl_sv_nv(pTHX_ register SV *sv)
4585 Perl_sv_pv(pTHX_ SV *sv)
4592 return sv_2pv(sv, &n_a);
4596 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4602 return sv_2pv(sv, lp);
4606 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4610 if (SvTHINKFIRST(sv) && !SvROK(sv))
4611 sv_force_normal(sv);
4617 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4619 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4620 PL_op_name[PL_op->op_type]);
4624 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4629 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4630 SvGROW(sv, len + 1);
4631 Move(s,SvPVX(sv),len,char);
4636 SvPOK_on(sv); /* validate pointer */
4638 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
4639 PTR2UV(sv),SvPVX(sv)));
4646 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4648 if (ob && SvOBJECT(sv))
4649 return HvNAME(SvSTASH(sv));
4651 switch (SvTYPE(sv)) {
4665 case SVt_PVLV: return "LVALUE";
4666 case SVt_PVAV: return "ARRAY";
4667 case SVt_PVHV: return "HASH";
4668 case SVt_PVCV: return "CODE";
4669 case SVt_PVGV: return "GLOB";
4670 case SVt_PVFM: return "FORMAT";
4671 default: return "UNKNOWN";
4677 Perl_sv_isobject(pTHX_ SV *sv)
4692 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4704 return strEQ(HvNAME(SvSTASH(sv)), name);
4708 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4715 SV_CHECK_THINKFIRST(rv);
4718 if (SvTYPE(rv) < SVt_RV)
4719 sv_upgrade(rv, SVt_RV);
4726 HV* stash = gv_stashpv(classname, TRUE);
4727 (void)sv_bless(rv, stash);
4733 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4736 sv_setsv(rv, &PL_sv_undef);
4740 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4745 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4747 sv_setiv(newSVrv(rv,classname), iv);
4752 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4754 sv_setnv(newSVrv(rv,classname), nv);
4759 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4761 sv_setpvn(newSVrv(rv,classname), pv, n);
4766 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4771 Perl_croak(aTHX_ "Can't bless non-reference value");
4773 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4774 if (SvREADONLY(tmpRef))
4775 Perl_croak(aTHX_ PL_no_modify);
4776 if (SvOBJECT(tmpRef)) {
4777 if (SvTYPE(tmpRef) != SVt_PVIO)
4779 SvREFCNT_dec(SvSTASH(tmpRef));
4782 SvOBJECT_on(tmpRef);
4783 if (SvTYPE(tmpRef) != SVt_PVIO)
4785 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4786 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4797 S_sv_unglob(pTHX_ SV *sv)
4799 assert(SvTYPE(sv) == SVt_PVGV);
4804 SvREFCNT_dec(GvSTASH(sv));
4805 GvSTASH(sv) = Nullhv;
4807 sv_unmagic(sv, '*');
4808 Safefree(GvNAME(sv));
4810 SvFLAGS(sv) &= ~SVTYPEMASK;
4811 SvFLAGS(sv) |= SVt_PVMG;
4815 Perl_sv_unref(pTHX_ SV *sv)
4819 if (SvWEAKREF(sv)) {
4827 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4830 sv_2mortal(rv); /* Schedule for freeing later */
4834 Perl_sv_taint(pTHX_ SV *sv)
4836 sv_magic((sv), Nullsv, 't', Nullch, 0);
4840 Perl_sv_untaint(pTHX_ SV *sv)
4842 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4843 MAGIC *mg = mg_find(sv, 't');
4850 Perl_sv_tainted(pTHX_ SV *sv)
4852 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4853 MAGIC *mg = mg_find(sv, 't');
4854 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4861 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4863 char buf[TYPE_CHARS(UV)];
4865 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4867 sv_setpvn(sv, ptr, ebuf - ptr);
4872 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4874 char buf[TYPE_CHARS(UV)];
4876 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4878 sv_setpvn(sv, ptr, ebuf - ptr);
4882 #if defined(PERL_IMPLICIT_CONTEXT)
4884 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4888 va_start(args, pat);
4889 sv_vsetpvf(sv, pat, &args);
4895 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4899 va_start(args, pat);
4900 sv_vsetpvf_mg(sv, pat, &args);
4906 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4909 va_start(args, pat);
4910 sv_vsetpvf(sv, pat, &args);
4915 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4917 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4921 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4924 va_start(args, pat);
4925 sv_vsetpvf_mg(sv, pat, &args);
4930 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4932 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4936 #if defined(PERL_IMPLICIT_CONTEXT)
4938 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4942 va_start(args, pat);
4943 sv_vcatpvf(sv, pat, &args);
4948 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4952 va_start(args, pat);
4953 sv_vcatpvf_mg(sv, pat, &args);
4959 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4962 va_start(args, pat);
4963 sv_vcatpvf(sv, pat, &args);
4968 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4970 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4974 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4977 va_start(args, pat);
4978 sv_vcatpvf_mg(sv, pat, &args);
4983 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4985 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4990 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
4992 sv_setpvn(sv, "", 0);
4993 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
4997 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5005 static char nullstr[] = "(null)";
5007 /* no matter what, this is a string now */
5008 (void)SvPV_force(sv, origlen);
5010 /* special-case "", "%s", and "%_" */
5013 if (patlen == 2 && pat[0] == '%') {
5017 char *s = va_arg(*args, char*);
5018 sv_catpv(sv, s ? s : nullstr);
5020 else if (svix < svmax)
5021 sv_catsv(sv, *svargs);
5025 sv_catsv(sv, va_arg(*args, SV*));
5028 /* See comment on '_' below */
5033 patend = (char*)pat + patlen;
5034 for (p = (char*)pat; p < patend; p = q) {
5042 bool has_precis = FALSE;
5047 STRLEN esignlen = 0;
5049 char *eptr = Nullch;
5051 /* Times 4: a decimal digit takes more than 3 binary digits.
5052 * NV_DIG: mantissa takes than many decimal digits.
5053 * Plus 32: Playing safe. */
5054 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5055 /* large enough for "%#.#f" --chip */
5056 /* what about long double NVs? --jhi */
5067 for (q = p; q < patend && *q != '%'; ++q) ;
5069 sv_catpvn(sv, p, q - p);
5107 case '1': case '2': case '3':
5108 case '4': case '5': case '6':
5109 case '7': case '8': case '9':
5112 width = width * 10 + (*q++ - '0');
5117 i = va_arg(*args, int);
5119 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5121 width = (i < 0) ? -i : i;
5132 i = va_arg(*args, int);
5134 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5135 precis = (i < 0) ? 0 : i;
5141 precis = precis * 10 + (*q++ - '0');
5158 if (*(q + 1) == 'l') { /* lld */
5186 uv = va_arg(*args, int);
5188 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5190 eptr = (char*)utf8buf;
5191 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5195 c = va_arg(*args, int);
5197 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5204 eptr = va_arg(*args, char*);
5206 elen = strlen(eptr);
5209 elen = sizeof nullstr - 1;
5212 else if (svix < svmax) {
5213 eptr = SvPVx(svargs[svix++], elen);
5215 if (has_precis && precis < elen) {
5217 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5220 if (width) { /* fudge width (can't fudge elen) */
5221 width += elen - sv_len_utf8(svargs[svix - 1]);
5229 * The "%_" hack might have to be changed someday,
5230 * if ISO or ANSI decide to use '_' for something.
5231 * So we keep it hidden from users' code.
5235 eptr = SvPVx(va_arg(*args, SV*), elen);
5238 if (has_precis && elen > precis)
5246 uv = PTR2UV(va_arg(*args, void*));
5248 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5263 case 'h': iv = (short)va_arg(*args, int); break;
5264 default: iv = va_arg(*args, int); break;
5265 case 'l': iv = va_arg(*args, long); break;
5266 case 'V': iv = va_arg(*args, IV); break;
5268 case 'q': iv = va_arg(*args, Quad_t); break;
5273 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5275 case 'h': iv = (short)iv; break;
5276 default: iv = (int)iv; break;
5277 case 'l': iv = (long)iv; break;
5280 case 'q': iv = (Quad_t)iv; break;
5287 esignbuf[esignlen++] = plus;
5291 esignbuf[esignlen++] = '-';
5329 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5330 default: uv = va_arg(*args, unsigned); break;
5331 case 'l': uv = va_arg(*args, unsigned long); break;
5332 case 'V': uv = va_arg(*args, UV); break;
5334 case 'q': uv = va_arg(*args, Quad_t); break;
5339 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5341 case 'h': uv = (unsigned short)uv; break;
5342 default: uv = (unsigned)uv; break;
5343 case 'l': uv = (unsigned long)uv; break;
5346 case 'q': uv = (Quad_t)uv; break;
5352 eptr = ebuf + sizeof ebuf;
5358 p = (c == 'X') ? "0123456789ABCDEF" : "0123456789abcdef";
5364 esignbuf[esignlen++] = '0';
5365 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5371 *--eptr = '0' + dig;
5373 if (alt && *eptr != '0')
5379 *--eptr = '0' + dig;
5382 esignbuf[esignlen++] = '0';
5383 esignbuf[esignlen++] = 'b';
5386 default: /* it had better be ten or less */
5387 #if defined(PERL_Y2KWARN)
5388 if (ckWARN(WARN_MISC)) {
5390 char *s = SvPV(sv,n);
5391 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5392 && (n == 2 || !isDIGIT(s[n-3])))
5394 Perl_warner(aTHX_ WARN_MISC,
5395 "Possible Y2K bug: %%%c %s",
5396 c, "format string following '19'");
5402 *--eptr = '0' + dig;
5403 } while (uv /= base);
5406 elen = (ebuf + sizeof ebuf) - eptr;
5409 zeros = precis - elen;
5410 else if (precis == 0 && elen == 1 && *eptr == '0')
5415 /* FLOATING POINT */
5418 c = 'f'; /* maybe %F isn't supported here */
5424 /* This is evil, but floating point is even more evil */
5427 nv = va_arg(*args, NV);
5429 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5432 if (c != 'e' && c != 'E') {
5434 (void)frexp(nv, &i);
5435 if (i == PERL_INT_MIN)
5436 Perl_die(aTHX_ "panic: frexp");
5438 need = BIT_DIGITS(i);
5440 need += has_precis ? precis : 6; /* known default */
5444 need += 20; /* fudge factor */
5445 if (PL_efloatsize < need) {
5446 Safefree(PL_efloatbuf);
5447 PL_efloatsize = need + 20; /* more fudge */
5448 New(906, PL_efloatbuf, PL_efloatsize, char);
5449 PL_efloatbuf[0] = '\0';
5452 eptr = ebuf + sizeof ebuf;
5455 #ifdef USE_LONG_DOUBLE
5457 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5458 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5463 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5468 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5481 RESTORE_NUMERIC_STANDARD();
5482 (void)sprintf(PL_efloatbuf, eptr, nv);
5483 RESTORE_NUMERIC_LOCAL();
5486 eptr = PL_efloatbuf;
5487 elen = strlen(PL_efloatbuf);
5489 #ifdef USE_LOCALE_NUMERIC
5491 * User-defined locales may include arbitrary characters.
5492 * And, unfortunately, some (broken) systems may allow the
5493 * "C" locale to be overridden by a malicious user.
5494 * XXX This is an extreme way to cope with broken systems.
5496 if (maybe_tainted && PL_tainting) {
5497 /* safe if it matches /[-+]?\d*(\.\d*)?([eE][-+]?\d*)?/ */
5498 if (*eptr == '-' || *eptr == '+')
5500 while (isDIGIT(*eptr))
5504 while (isDIGIT(*eptr))
5507 if (*eptr == 'e' || *eptr == 'E') {
5509 if (*eptr == '-' || *eptr == '+')
5511 while (isDIGIT(*eptr))
5515 *maybe_tainted = TRUE; /* results are suspect */
5516 eptr = PL_efloatbuf;
5518 #endif /* USE_LOCALE_NUMERIC */
5525 i = SvCUR(sv) - origlen;
5528 case 'h': *(va_arg(*args, short*)) = i; break;
5529 default: *(va_arg(*args, int*)) = i; break;
5530 case 'l': *(va_arg(*args, long*)) = i; break;
5531 case 'V': *(va_arg(*args, IV*)) = i; break;
5533 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5537 else if (svix < svmax)
5538 sv_setuv(svargs[svix++], (UV)i);
5539 continue; /* not "break" */
5545 if (!args && ckWARN(WARN_PRINTF) &&
5546 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5547 SV *msg = sv_newmortal();
5548 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5549 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5552 Perl_sv_catpvf(aTHX_ msg,
5553 "\"%%%c\"", c & 0xFF);
5555 Perl_sv_catpvf(aTHX_ msg,
5556 "\"%%\\%03"UVof"\"",
5559 sv_catpv(msg, "end of string");
5560 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5563 /* output mangled stuff ... */
5569 /* ... right here, because formatting flags should not apply */
5570 SvGROW(sv, SvCUR(sv) + elen + 1);
5572 memcpy(p, eptr, elen);
5575 SvCUR(sv) = p - SvPVX(sv);
5576 continue; /* not "break" */
5579 have = esignlen + zeros + elen;
5580 need = (have > width ? have : width);
5583 SvGROW(sv, SvCUR(sv) + need + 1);
5585 if (esignlen && fill == '0') {
5586 for (i = 0; i < esignlen; i++)
5590 memset(p, fill, gap);
5593 if (esignlen && fill != '0') {
5594 for (i = 0; i < esignlen; i++)
5598 for (i = zeros; i; i--)
5602 memcpy(p, eptr, elen);
5606 memset(p, ' ', gap);
5610 SvCUR(sv) = p - SvPVX(sv);
5621 do_report_used(pTHXo_ SV *sv)
5623 if (SvTYPE(sv) != SVTYPEMASK) {
5624 PerlIO_printf(Perl_debug_log, "****\n");
5630 do_clean_objs(pTHXo_ SV *sv)
5634 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
5635 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
5641 /* XXX Might want to check arrays, etc. */
5644 #ifndef DISABLE_DESTRUCTOR_KLUDGE
5646 do_clean_named_objs(pTHXo_ SV *sv)
5648 if (SvTYPE(sv) == SVt_PVGV) {
5649 if ( SvOBJECT(GvSV(sv)) ||
5650 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
5651 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
5652 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
5653 GvCV(sv) && SvOBJECT(GvCV(sv)) )
5655 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
5663 do_clean_all(pTHXo_ SV *sv)
5665 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
5666 SvFLAGS(sv) |= SVf_BREAK;