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;
320 Perl_report_uninit(pTHX)
323 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
324 " in ", PL_op_desc[PL_op->op_type]);
326 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
338 * See comment in more_xiv() -- RAM.
340 PL_xiv_root = *(IV**)xiv;
342 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
346 S_del_xiv(pTHX_ XPVIV *p)
348 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
350 *(IV**)xiv = PL_xiv_root;
361 New(705, ptr, 1008/sizeof(XPV), XPV);
362 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
363 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
366 xivend = &xiv[1008 / sizeof(IV) - 1];
367 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
369 while (xiv < xivend) {
370 *(IV**)xiv = (IV *)(xiv + 1);
384 PL_xnv_root = *(NV**)xnv;
386 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
390 S_del_xnv(pTHX_ XPVNV *p)
392 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
394 *(NV**)xnv = PL_xnv_root;
404 New(711, xnv, 1008/sizeof(NV), NV);
405 xnvend = &xnv[1008 / sizeof(NV) - 1];
406 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
408 while (xnv < xnvend) {
409 *(NV**)xnv = (NV*)(xnv + 1);
423 PL_xrv_root = (XRV*)xrv->xrv_rv;
429 S_del_xrv(pTHX_ XRV *p)
432 p->xrv_rv = (SV*)PL_xrv_root;
441 register XRV* xrvend;
442 New(712, PL_xrv_root, 1008/sizeof(XRV), XRV);
444 xrvend = &xrv[1008 / sizeof(XRV) - 1];
445 while (xrv < xrvend) {
446 xrv->xrv_rv = (SV*)(xrv + 1);
460 PL_xpv_root = (XPV*)xpv->xpv_pv;
466 S_del_xpv(pTHX_ XPV *p)
469 p->xpv_pv = (char*)PL_xpv_root;
478 register XPV* xpvend;
479 New(713, PL_xpv_root, 1008/sizeof(XPV), XPV);
481 xpvend = &xpv[1008 / sizeof(XPV) - 1];
482 while (xpv < xpvend) {
483 xpv->xpv_pv = (char*)(xpv + 1);
496 xpviv = PL_xpviv_root;
497 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
503 S_del_xpviv(pTHX_ XPVIV *p)
506 p->xpv_pv = (char*)PL_xpviv_root;
515 register XPVIV* xpviv;
516 register XPVIV* xpvivend;
517 New(714, PL_xpviv_root, 1008/sizeof(XPVIV), XPVIV);
518 xpviv = PL_xpviv_root;
519 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
520 while (xpviv < xpvivend) {
521 xpviv->xpv_pv = (char*)(xpviv + 1);
535 xpvnv = PL_xpvnv_root;
536 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
542 S_del_xpvnv(pTHX_ XPVNV *p)
545 p->xpv_pv = (char*)PL_xpvnv_root;
554 register XPVNV* xpvnv;
555 register XPVNV* xpvnvend;
556 New(715, PL_xpvnv_root, 1008/sizeof(XPVNV), XPVNV);
557 xpvnv = PL_xpvnv_root;
558 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
559 while (xpvnv < xpvnvend) {
560 xpvnv->xpv_pv = (char*)(xpvnv + 1);
575 xpvcv = PL_xpvcv_root;
576 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
582 S_del_xpvcv(pTHX_ XPVCV *p)
585 p->xpv_pv = (char*)PL_xpvcv_root;
594 register XPVCV* xpvcv;
595 register XPVCV* xpvcvend;
596 New(716, PL_xpvcv_root, 1008/sizeof(XPVCV), XPVCV);
597 xpvcv = PL_xpvcv_root;
598 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
599 while (xpvcv < xpvcvend) {
600 xpvcv->xpv_pv = (char*)(xpvcv + 1);
615 xpvav = PL_xpvav_root;
616 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
622 S_del_xpvav(pTHX_ XPVAV *p)
625 p->xav_array = (char*)PL_xpvav_root;
634 register XPVAV* xpvav;
635 register XPVAV* xpvavend;
636 New(717, PL_xpvav_root, 1008/sizeof(XPVAV), XPVAV);
637 xpvav = PL_xpvav_root;
638 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
639 while (xpvav < xpvavend) {
640 xpvav->xav_array = (char*)(xpvav + 1);
643 xpvav->xav_array = 0;
655 xpvhv = PL_xpvhv_root;
656 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
662 S_del_xpvhv(pTHX_ XPVHV *p)
665 p->xhv_array = (char*)PL_xpvhv_root;
674 register XPVHV* xpvhv;
675 register XPVHV* xpvhvend;
676 New(718, PL_xpvhv_root, 1008/sizeof(XPVHV), XPVHV);
677 xpvhv = PL_xpvhv_root;
678 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
679 while (xpvhv < xpvhvend) {
680 xpvhv->xhv_array = (char*)(xpvhv + 1);
683 xpvhv->xhv_array = 0;
694 xpvmg = PL_xpvmg_root;
695 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
701 S_del_xpvmg(pTHX_ XPVMG *p)
704 p->xpv_pv = (char*)PL_xpvmg_root;
713 register XPVMG* xpvmg;
714 register XPVMG* xpvmgend;
715 New(719, PL_xpvmg_root, 1008/sizeof(XPVMG), XPVMG);
716 xpvmg = PL_xpvmg_root;
717 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
718 while (xpvmg < xpvmgend) {
719 xpvmg->xpv_pv = (char*)(xpvmg + 1);
734 xpvlv = PL_xpvlv_root;
735 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
741 S_del_xpvlv(pTHX_ XPVLV *p)
744 p->xpv_pv = (char*)PL_xpvlv_root;
753 register XPVLV* xpvlv;
754 register XPVLV* xpvlvend;
755 New(720, PL_xpvlv_root, 1008/sizeof(XPVLV), XPVLV);
756 xpvlv = PL_xpvlv_root;
757 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
758 while (xpvlv < xpvlvend) {
759 xpvlv->xpv_pv = (char*)(xpvlv + 1);
773 xpvbm = PL_xpvbm_root;
774 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
780 S_del_xpvbm(pTHX_ XPVBM *p)
783 p->xpv_pv = (char*)PL_xpvbm_root;
792 register XPVBM* xpvbm;
793 register XPVBM* xpvbmend;
794 New(721, PL_xpvbm_root, 1008/sizeof(XPVBM), XPVBM);
795 xpvbm = PL_xpvbm_root;
796 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
797 while (xpvbm < xpvbmend) {
798 xpvbm->xpv_pv = (char*)(xpvbm + 1);
805 #define new_XIV() (void*)safemalloc(sizeof(XPVIV))
806 #define del_XIV(p) Safefree((char*)p)
808 #define new_XIV() (void*)new_xiv()
809 #define del_XIV(p) del_xiv((XPVIV*) p)
813 #define new_XNV() (void*)safemalloc(sizeof(XPVNV))
814 #define del_XNV(p) Safefree((char*)p)
816 #define new_XNV() (void*)new_xnv()
817 #define del_XNV(p) del_xnv((XPVNV*) p)
821 #define new_XRV() (void*)safemalloc(sizeof(XRV))
822 #define del_XRV(p) Safefree((char*)p)
824 #define new_XRV() (void*)new_xrv()
825 #define del_XRV(p) del_xrv((XRV*) p)
829 #define new_XPV() (void*)safemalloc(sizeof(XPV))
830 #define del_XPV(p) Safefree((char*)p)
832 #define new_XPV() (void*)new_xpv()
833 #define del_XPV(p) del_xpv((XPV *)p)
837 # define my_safemalloc(s) safemalloc(s)
838 # define my_safefree(s) safefree(s)
841 S_my_safemalloc(MEM_SIZE size)
844 New(717, p, size, char);
847 # define my_safefree(s) Safefree(s)
851 #define new_XPVIV() (void*)safemalloc(sizeof(XPVIV))
852 #define del_XPVIV(p) Safefree((char*)p)
854 #define new_XPVIV() (void*)new_xpviv()
855 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
859 #define new_XPVNV() (void*)safemalloc(sizeof(XPVNV))
860 #define del_XPVNV(p) Safefree((char*)p)
862 #define new_XPVNV() (void*)new_xpvnv()
863 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
868 #define new_XPVCV() (void*)safemalloc(sizeof(XPVCV))
869 #define del_XPVCV(p) Safefree((char*)p)
871 #define new_XPVCV() (void*)new_xpvcv()
872 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
876 #define new_XPVAV() (void*)safemalloc(sizeof(XPVAV))
877 #define del_XPVAV(p) Safefree((char*)p)
879 #define new_XPVAV() (void*)new_xpvav()
880 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
884 #define new_XPVHV() (void*)safemalloc(sizeof(XPVHV))
885 #define del_XPVHV(p) Safefree((char*)p)
887 #define new_XPVHV() (void*)new_xpvhv()
888 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
892 #define new_XPVMG() (void*)safemalloc(sizeof(XPVMG))
893 #define del_XPVMG(p) Safefree((char*)p)
895 #define new_XPVMG() (void*)new_xpvmg()
896 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
900 #define new_XPVLV() (void*)safemalloc(sizeof(XPVLV))
901 #define del_XPVLV(p) Safefree((char*)p)
903 #define new_XPVLV() (void*)new_xpvlv()
904 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
907 #define new_XPVGV() (void*)my_safemalloc(sizeof(XPVGV))
908 #define del_XPVGV(p) my_safefree((char*)p)
911 #define new_XPVBM() (void*)safemalloc(sizeof(XPVBM))
912 #define del_XPVBM(p) Safefree((char*)p)
914 #define new_XPVBM() (void*)new_xpvbm()
915 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
918 #define new_XPVFM() (void*)my_safemalloc(sizeof(XPVFM))
919 #define del_XPVFM(p) my_safefree((char*)p)
921 #define new_XPVIO() (void*)my_safemalloc(sizeof(XPVIO))
922 #define del_XPVIO(p) my_safefree((char*)p)
925 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
935 if (SvTYPE(sv) == mt)
941 switch (SvTYPE(sv)) {
962 else if (mt < SVt_PVIV)
979 pv = (char*)SvRV(sv);
999 else if (mt == SVt_NV)
1010 del_XPVIV(SvANY(sv));
1020 del_XPVNV(SvANY(sv));
1028 magic = SvMAGIC(sv);
1029 stash = SvSTASH(sv);
1030 del_XPVMG(SvANY(sv));
1033 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1038 Perl_croak(aTHX_ "Can't upgrade to undef");
1040 SvANY(sv) = new_XIV();
1044 SvANY(sv) = new_XNV();
1048 SvANY(sv) = new_XRV();
1052 SvANY(sv) = new_XPV();
1058 SvANY(sv) = new_XPVIV();
1068 SvANY(sv) = new_XPVNV();
1076 SvANY(sv) = new_XPVMG();
1082 SvMAGIC(sv) = magic;
1083 SvSTASH(sv) = stash;
1086 SvANY(sv) = new_XPVLV();
1092 SvMAGIC(sv) = magic;
1093 SvSTASH(sv) = stash;
1100 SvANY(sv) = new_XPVAV();
1108 SvMAGIC(sv) = magic;
1109 SvSTASH(sv) = stash;
1115 SvANY(sv) = new_XPVHV();
1123 SvMAGIC(sv) = magic;
1124 SvSTASH(sv) = stash;
1131 SvANY(sv) = new_XPVCV();
1132 Zero(SvANY(sv), 1, XPVCV);
1138 SvMAGIC(sv) = magic;
1139 SvSTASH(sv) = stash;
1142 SvANY(sv) = new_XPVGV();
1148 SvMAGIC(sv) = magic;
1149 SvSTASH(sv) = stash;
1157 SvANY(sv) = new_XPVBM();
1163 SvMAGIC(sv) = magic;
1164 SvSTASH(sv) = stash;
1170 SvANY(sv) = new_XPVFM();
1171 Zero(SvANY(sv), 1, XPVFM);
1177 SvMAGIC(sv) = magic;
1178 SvSTASH(sv) = stash;
1181 SvANY(sv) = new_XPVIO();
1182 Zero(SvANY(sv), 1, XPVIO);
1188 SvMAGIC(sv) = magic;
1189 SvSTASH(sv) = stash;
1190 IoPAGE_LEN(sv) = 60;
1193 SvFLAGS(sv) &= ~SVTYPEMASK;
1199 Perl_sv_backoff(pTHX_ register SV *sv)
1203 char *s = SvPVX(sv);
1204 SvLEN(sv) += SvIVX(sv);
1205 SvPVX(sv) -= SvIVX(sv);
1207 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1209 SvFLAGS(sv) &= ~SVf_OOK;
1214 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1218 #ifdef HAS_64K_LIMIT
1219 if (newlen >= 0x10000) {
1220 PerlIO_printf(Perl_debug_log,
1221 "Allocation too large: %"UVxf"\n", (UV)newlen);
1224 #endif /* HAS_64K_LIMIT */
1227 if (SvTYPE(sv) < SVt_PV) {
1228 sv_upgrade(sv, SVt_PV);
1231 else if (SvOOK(sv)) { /* pv is offset? */
1234 if (newlen > SvLEN(sv))
1235 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1236 #ifdef HAS_64K_LIMIT
1237 if (newlen >= 0x10000)
1243 if (newlen > SvLEN(sv)) { /* need more room? */
1244 if (SvLEN(sv) && s) {
1245 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
1246 STRLEN l = malloced_size((void*)SvPVX(sv));
1252 Renew(s,newlen,char);
1255 New(703,s,newlen,char);
1257 SvLEN_set(sv, newlen);
1263 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1265 SV_CHECK_THINKFIRST(sv);
1266 switch (SvTYPE(sv)) {
1268 sv_upgrade(sv, SVt_IV);
1271 sv_upgrade(sv, SVt_PVNV);
1275 sv_upgrade(sv, SVt_PVIV);
1286 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1287 PL_op_desc[PL_op->op_type]);
1290 (void)SvIOK_only(sv); /* validate number */
1296 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1303 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1311 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1318 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1320 SV_CHECK_THINKFIRST(sv);
1321 switch (SvTYPE(sv)) {
1324 sv_upgrade(sv, SVt_NV);
1329 sv_upgrade(sv, SVt_PVNV);
1340 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1341 PL_op_name[PL_op->op_type]);
1345 (void)SvNOK_only(sv); /* validate number */
1350 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1357 S_not_a_number(pTHX_ SV *sv)
1363 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1364 /* each *s can expand to 4 chars + "...\0",
1365 i.e. need room for 8 chars */
1367 for (s = SvPVX(sv); *s && d < limit; s++) {
1369 if (ch & 128 && !isPRINT_LC(ch)) {
1378 else if (ch == '\r') {
1382 else if (ch == '\f') {
1386 else if (ch == '\\') {
1390 else if (isPRINT_LC(ch))
1405 Perl_warner(aTHX_ WARN_NUMERIC,
1406 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1407 PL_op_desc[PL_op->op_type]);
1409 Perl_warner(aTHX_ WARN_NUMERIC,
1410 "Argument \"%s\" isn't numeric", tmpbuf);
1413 /* the number can be converted to integer with atol() or atoll() */
1414 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1415 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1416 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1417 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1419 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1420 until proven guilty, assume that things are not that bad... */
1423 Perl_sv_2iv(pTHX_ register SV *sv)
1427 if (SvGMAGICAL(sv)) {
1432 return I_V(SvNVX(sv));
1434 if (SvPOKp(sv) && SvLEN(sv))
1437 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1439 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1445 if (SvTHINKFIRST(sv)) {
1448 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1449 return SvIV(tmpstr);
1450 return PTR2IV(SvRV(sv));
1452 if (SvREADONLY(sv) && !SvOK(sv)) {
1454 if (ckWARN(WARN_UNINITIALIZED))
1461 return (IV)(SvUVX(sv));
1468 /* We can cache the IV/UV value even if it not good enough
1469 * to reconstruct NV, since the conversion to PV will prefer
1473 if (SvTYPE(sv) == SVt_NV)
1474 sv_upgrade(sv, SVt_PVNV);
1477 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1478 SvIVX(sv) = I_V(SvNVX(sv));
1480 SvUVX(sv) = U_V(SvNVX(sv));
1483 DEBUG_c(PerlIO_printf(Perl_debug_log,
1484 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1488 return (IV)SvUVX(sv);
1491 else if (SvPOKp(sv) && SvLEN(sv)) {
1492 I32 numtype = looks_like_number(sv);
1494 /* We want to avoid a possible problem when we cache an IV which
1495 may be later translated to an NV, and the resulting NV is not
1496 the translation of the initial data.
1498 This means that if we cache such an IV, we need to cache the
1499 NV as well. Moreover, we trade speed for space, and do not
1500 cache the NV if not needed.
1502 if (numtype & IS_NUMBER_NOT_IV) {
1503 /* May be not an integer. Need to cache NV if we cache IV
1504 * - otherwise future conversion to NV will be wrong. */
1507 d = Atof(SvPVX(sv));
1509 if (SvTYPE(sv) < SVt_PVNV)
1510 sv_upgrade(sv, SVt_PVNV);
1514 #if defined(USE_LONG_DOUBLE)
1515 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1516 PTR2UV(sv), SvNVX(sv)));
1518 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1519 PTR2UV(sv), SvNVX(sv)));
1521 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1522 SvIVX(sv) = I_V(SvNVX(sv));
1524 SvUVX(sv) = U_V(SvNVX(sv));
1530 /* The NV may be reconstructed from IV - safe to cache IV,
1531 which may be calculated by atol(). */
1532 if (SvTYPE(sv) == SVt_PV)
1533 sv_upgrade(sv, SVt_PVIV);
1535 SvIVX(sv) = Atol(SvPVX(sv));
1537 else { /* Not a number. Cache 0. */
1540 if (SvTYPE(sv) < SVt_PVIV)
1541 sv_upgrade(sv, SVt_PVIV);
1544 if (ckWARN(WARN_NUMERIC))
1550 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1552 if (SvTYPE(sv) < SVt_IV)
1553 /* Typically the caller expects that sv_any is not NULL now. */
1554 sv_upgrade(sv, SVt_IV);
1557 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1558 PTR2UV(sv),SvIVX(sv)));
1559 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1563 Perl_sv_2uv(pTHX_ register SV *sv)
1567 if (SvGMAGICAL(sv)) {
1572 return U_V(SvNVX(sv));
1573 if (SvPOKp(sv) && SvLEN(sv))
1576 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1578 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1584 if (SvTHINKFIRST(sv)) {
1587 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1588 return SvUV(tmpstr);
1589 return PTR2UV(SvRV(sv));
1591 if (SvREADONLY(sv) && !SvOK(sv)) {
1593 if (ckWARN(WARN_UNINITIALIZED))
1603 return (UV)SvIVX(sv);
1607 /* We can cache the IV/UV value even if it not good enough
1608 * to reconstruct NV, since the conversion to PV will prefer
1611 if (SvTYPE(sv) == SVt_NV)
1612 sv_upgrade(sv, SVt_PVNV);
1614 if (SvNVX(sv) >= -0.5) {
1616 SvUVX(sv) = U_V(SvNVX(sv));
1619 SvIVX(sv) = I_V(SvNVX(sv));
1621 DEBUG_c(PerlIO_printf(Perl_debug_log,
1622 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1625 (IV)(UV)SvIVX(sv)));
1626 return (UV)SvIVX(sv);
1629 else if (SvPOKp(sv) && SvLEN(sv)) {
1630 I32 numtype = looks_like_number(sv);
1632 /* We want to avoid a possible problem when we cache a UV which
1633 may be later translated to an NV, and the resulting NV is not
1634 the translation of the initial data.
1636 This means that if we cache such a UV, we need to cache the
1637 NV as well. Moreover, we trade speed for space, and do not
1638 cache the NV if not needed.
1640 if (numtype & IS_NUMBER_NOT_IV) {
1641 /* May be not an integer. Need to cache NV if we cache IV
1642 * - otherwise future conversion to NV will be wrong. */
1645 d = Atof(SvPVX(sv));
1647 if (SvTYPE(sv) < SVt_PVNV)
1648 sv_upgrade(sv, SVt_PVNV);
1652 #if defined(USE_LONG_DOUBLE)
1653 DEBUG_c(PerlIO_printf(Perl_debug_log,
1654 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1655 PTR2UV(sv), SvNVX(sv)));
1657 DEBUG_c(PerlIO_printf(Perl_debug_log,
1658 "0x%"UVxf" 2nv(%g)\n",
1659 PTR2UV(sv), SvNVX(sv)));
1661 if (SvNVX(sv) < -0.5) {
1662 SvIVX(sv) = I_V(SvNVX(sv));
1665 SvUVX(sv) = U_V(SvNVX(sv));
1669 else if (numtype & IS_NUMBER_NEG) {
1670 /* The NV may be reconstructed from IV - safe to cache IV,
1671 which may be calculated by atol(). */
1672 if (SvTYPE(sv) == SVt_PV)
1673 sv_upgrade(sv, SVt_PVIV);
1675 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1677 else if (numtype) { /* Non-negative */
1678 /* The NV may be reconstructed from UV - safe to cache UV,
1679 which may be calculated by strtoul()/atol. */
1680 if (SvTYPE(sv) == SVt_PV)
1681 sv_upgrade(sv, SVt_PVIV);
1683 (void)SvIsUV_on(sv);
1685 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1686 #else /* no atou(), but we know the number fits into IV... */
1687 /* The only problem may be if it is negative... */
1688 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1691 else { /* Not a number. Cache 0. */
1694 if (SvTYPE(sv) < SVt_PVIV)
1695 sv_upgrade(sv, SVt_PVIV);
1696 SvUVX(sv) = 0; /* We assume that 0s have the
1697 same bitmap in IV and UV. */
1699 (void)SvIsUV_on(sv);
1700 if (ckWARN(WARN_NUMERIC))
1705 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1707 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1710 if (SvTYPE(sv) < SVt_IV)
1711 /* Typically the caller expects that sv_any is not NULL now. */
1712 sv_upgrade(sv, SVt_IV);
1716 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1717 PTR2UV(sv),SvUVX(sv)));
1718 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1722 Perl_sv_2nv(pTHX_ register SV *sv)
1726 if (SvGMAGICAL(sv)) {
1730 if (SvPOKp(sv) && SvLEN(sv)) {
1732 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1734 return Atof(SvPVX(sv));
1738 return (NV)SvUVX(sv);
1740 return (NV)SvIVX(sv);
1743 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1745 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1751 if (SvTHINKFIRST(sv)) {
1754 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1755 return SvNV(tmpstr);
1756 return PTR2NV(SvRV(sv));
1758 if (SvREADONLY(sv) && !SvOK(sv)) {
1760 if (ckWARN(WARN_UNINITIALIZED))
1765 if (SvTYPE(sv) < SVt_NV) {
1766 if (SvTYPE(sv) == SVt_IV)
1767 sv_upgrade(sv, SVt_PVNV);
1769 sv_upgrade(sv, SVt_NV);
1770 #if defined(USE_LONG_DOUBLE)
1772 RESTORE_NUMERIC_STANDARD();
1773 PerlIO_printf(Perl_debug_log,
1774 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1775 PTR2UV(sv), SvNVX(sv));
1776 RESTORE_NUMERIC_LOCAL();
1780 RESTORE_NUMERIC_STANDARD();
1781 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1782 PTR2UV(sv), SvNVX(sv));
1783 RESTORE_NUMERIC_LOCAL();
1787 else if (SvTYPE(sv) < SVt_PVNV)
1788 sv_upgrade(sv, SVt_PVNV);
1790 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1792 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1794 else if (SvPOKp(sv) && SvLEN(sv)) {
1796 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1798 SvNVX(sv) = Atof(SvPVX(sv));
1802 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1804 if (SvTYPE(sv) < SVt_NV)
1805 /* Typically the caller expects that sv_any is not NULL now. */
1806 sv_upgrade(sv, SVt_NV);
1810 #if defined(USE_LONG_DOUBLE)
1812 RESTORE_NUMERIC_STANDARD();
1813 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1814 PTR2UV(sv), SvNVX(sv));
1815 RESTORE_NUMERIC_LOCAL();
1819 RESTORE_NUMERIC_STANDARD();
1820 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1821 PTR2UV(sv), SvNVX(sv));
1822 RESTORE_NUMERIC_LOCAL();
1829 S_asIV(pTHX_ SV *sv)
1831 I32 numtype = looks_like_number(sv);
1834 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1835 return Atol(SvPVX(sv));
1838 if (ckWARN(WARN_NUMERIC))
1841 d = Atof(SvPVX(sv));
1846 S_asUV(pTHX_ SV *sv)
1848 I32 numtype = looks_like_number(sv);
1851 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1852 return Strtoul(SvPVX(sv), Null(char**), 10);
1856 if (ckWARN(WARN_NUMERIC))
1859 return U_V(Atof(SvPVX(sv)));
1863 * Returns a combination of (advisory only - can get false negatives)
1864 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1866 * 0 if does not look like number.
1868 * In fact possible values are 0 and
1869 * IS_NUMBER_TO_INT_BY_ATOL 123
1870 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1871 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1872 * with a possible addition of IS_NUMBER_NEG.
1876 Perl_looks_like_number(pTHX_ SV *sv)
1879 register char *send;
1880 register char *sbegin;
1881 register char *nbegin;
1889 else if (SvPOKp(sv))
1890 sbegin = SvPV(sv, len);
1893 send = sbegin + len;
1900 numtype = IS_NUMBER_NEG;
1907 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1908 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1912 /* next must be digit or the radix separator */
1916 } while (isDIGIT(*s));
1918 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1919 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1921 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1924 #ifdef USE_LOCALE_NUMERIC
1925 || IS_NUMERIC_RADIX(*s)
1929 numtype |= IS_NUMBER_NOT_IV;
1930 while (isDIGIT(*s)) /* optional digits after the radix */
1935 #ifdef USE_LOCALE_NUMERIC
1936 || IS_NUMERIC_RADIX(*s)
1940 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1941 /* no digits before the radix means we need digits after it */
1945 } while (isDIGIT(*s));
1953 /* we can have an optional exponent part */
1954 if (*s == 'e' || *s == 'E') {
1955 numtype &= ~IS_NUMBER_NEG;
1956 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1958 if (*s == '+' || *s == '-')
1963 } while (isDIGIT(*s));
1972 if (len == 10 && memEQ(sbegin, "0 but true", 10))
1973 return IS_NUMBER_TO_INT_BY_ATOL;
1978 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
1981 return sv_2pv(sv, &n_a);
1984 /* We assume that buf is at least TYPE_CHARS(UV) long. */
1986 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
1989 char *ptr = buf + TYPE_CHARS(UV);
2004 *--ptr = '0' + (uv % 10);
2013 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2018 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2019 char *tmpbuf = tbuf;
2025 if (SvGMAGICAL(sv)) {
2033 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2035 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2040 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2045 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2047 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2054 if (SvTHINKFIRST(sv)) {
2057 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2058 return SvPV(tmpstr,*lp);
2065 switch (SvTYPE(sv)) {
2067 if ( ((SvFLAGS(sv) &
2068 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2069 == (SVs_OBJECT|SVs_RMG))
2070 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2071 && (mg = mg_find(sv, 'r'))) {
2073 regexp *re = (regexp *)mg->mg_obj;
2076 char *fptr = "msix";
2081 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2083 while(ch = *fptr++) {
2085 reflags[left++] = ch;
2088 reflags[right--] = ch;
2093 reflags[left] = '-';
2097 mg->mg_len = re->prelen + 4 + left;
2098 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2099 Copy("(?", mg->mg_ptr, 2, char);
2100 Copy(reflags, mg->mg_ptr+2, left, char);
2101 Copy(":", mg->mg_ptr+left+2, 1, char);
2102 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2103 mg->mg_ptr[mg->mg_len - 1] = ')';
2104 mg->mg_ptr[mg->mg_len] = 0;
2106 PL_reginterp_cnt += re->program[0].next_off;
2118 case SVt_PVBM: s = "SCALAR"; break;
2119 case SVt_PVLV: s = "LVALUE"; break;
2120 case SVt_PVAV: s = "ARRAY"; break;
2121 case SVt_PVHV: s = "HASH"; break;
2122 case SVt_PVCV: s = "CODE"; break;
2123 case SVt_PVGV: s = "GLOB"; break;
2124 case SVt_PVFM: s = "FORMAT"; break;
2125 case SVt_PVIO: s = "IO"; break;
2126 default: s = "UNKNOWN"; break;
2130 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2133 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2139 if (SvREADONLY(sv) && !SvOK(sv)) {
2141 if (ckWARN(WARN_UNINITIALIZED))
2147 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2148 /* XXXX 64-bit? IV may have better precision... */
2149 /* I tried changing this for to be 64-bit-aware and
2150 * the t/op/numconvert.t became very, very, angry.
2152 if (SvTYPE(sv) < SVt_PVNV)
2153 sv_upgrade(sv, SVt_PVNV);
2156 olderrno = errno; /* some Xenix systems wipe out errno here */
2158 if (SvNVX(sv) == 0.0)
2159 (void)strcpy(s,"0");
2163 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2166 #ifdef FIXNEGATIVEZERO
2167 if (*s == '-' && s[1] == '0' && !s[2])
2176 else if (SvIOKp(sv)) {
2177 U32 isIOK = SvIOK(sv);
2178 U32 isUIOK = SvIsUV(sv);
2179 char buf[TYPE_CHARS(UV)];
2182 if (SvTYPE(sv) < SVt_PVIV)
2183 sv_upgrade(sv, SVt_PVIV);
2185 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2187 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2188 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2189 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2190 SvCUR_set(sv, ebuf - ptr);
2203 if (ckWARN(WARN_UNINITIALIZED)
2204 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2209 if (SvTYPE(sv) < SVt_PV)
2210 /* Typically the caller expects that sv_any is not NULL now. */
2211 sv_upgrade(sv, SVt_PV);
2214 *lp = s - SvPVX(sv);
2217 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2218 PTR2UV(sv),SvPVX(sv)));
2222 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2223 /* Sneaky stuff here */
2227 tsv = newSVpv(tmpbuf, 0);
2243 len = strlen(tmpbuf);
2245 #ifdef FIXNEGATIVEZERO
2246 if (len == 2 && t[0] == '-' && t[1] == '0') {
2251 (void)SvUPGRADE(sv, SVt_PV);
2253 s = SvGROW(sv, len + 1);
2262 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2264 return sv_2pv_nolen(sv);
2268 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2270 return sv_2pv(sv,lp);
2274 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2276 return sv_2pv_nolen(sv);
2280 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2282 return sv_2pv(sv,lp);
2285 /* This function is only called on magical items */
2287 Perl_sv_2bool(pTHX_ register SV *sv)
2297 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2298 return SvTRUE(tmpsv);
2299 return SvRV(sv) != 0;
2302 register XPV* Xpvtmp;
2303 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2304 (*Xpvtmp->xpv_pv > '0' ||
2305 Xpvtmp->xpv_cur > 1 ||
2306 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2313 return SvIVX(sv) != 0;
2316 return SvNVX(sv) != 0.0;
2323 /* Note: sv_setsv() should not be called with a source string that needs
2324 * to be reused, since it may destroy the source string if it is marked
2329 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2332 register U32 sflags;
2338 SV_CHECK_THINKFIRST(dstr);
2340 sstr = &PL_sv_undef;
2341 stype = SvTYPE(sstr);
2342 dtype = SvTYPE(dstr);
2346 /* There's a lot of redundancy below but we're going for speed here */
2351 if (dtype != SVt_PVGV) {
2352 (void)SvOK_off(dstr);
2360 sv_upgrade(dstr, SVt_IV);
2363 sv_upgrade(dstr, SVt_PVNV);
2367 sv_upgrade(dstr, SVt_PVIV);
2370 (void)SvIOK_only(dstr);
2371 SvIVX(dstr) = SvIVX(sstr);
2384 sv_upgrade(dstr, SVt_NV);
2389 sv_upgrade(dstr, SVt_PVNV);
2392 SvNVX(dstr) = SvNVX(sstr);
2393 (void)SvNOK_only(dstr);
2401 sv_upgrade(dstr, SVt_RV);
2402 else if (dtype == SVt_PVGV &&
2403 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2406 if (GvIMPORTED(dstr) != GVf_IMPORTED
2407 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2409 GvIMPORTED_on(dstr);
2420 sv_upgrade(dstr, SVt_PV);
2423 if (dtype < SVt_PVIV)
2424 sv_upgrade(dstr, SVt_PVIV);
2427 if (dtype < SVt_PVNV)
2428 sv_upgrade(dstr, SVt_PVNV);
2435 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2436 PL_op_name[PL_op->op_type]);
2438 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2442 if (dtype <= SVt_PVGV) {
2444 if (dtype != SVt_PVGV) {
2445 char *name = GvNAME(sstr);
2446 STRLEN len = GvNAMELEN(sstr);
2447 sv_upgrade(dstr, SVt_PVGV);
2448 sv_magic(dstr, dstr, '*', name, len);
2449 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2450 GvNAME(dstr) = savepvn(name, len);
2451 GvNAMELEN(dstr) = len;
2452 SvFAKE_on(dstr); /* can coerce to non-glob */
2454 /* ahem, death to those who redefine active sort subs */
2455 else if (PL_curstackinfo->si_type == PERLSI_SORT
2456 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2457 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2459 (void)SvOK_off(dstr);
2460 GvINTRO_off(dstr); /* one-shot flag */
2462 GvGP(dstr) = gp_ref(GvGP(sstr));
2464 if (GvIMPORTED(dstr) != GVf_IMPORTED
2465 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2467 GvIMPORTED_on(dstr);
2475 if (SvGMAGICAL(sstr)) {
2477 if (SvTYPE(sstr) != stype) {
2478 stype = SvTYPE(sstr);
2479 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2483 if (stype == SVt_PVLV)
2484 (void)SvUPGRADE(dstr, SVt_PVNV);
2486 (void)SvUPGRADE(dstr, stype);
2489 sflags = SvFLAGS(sstr);
2491 if (sflags & SVf_ROK) {
2492 if (dtype >= SVt_PV) {
2493 if (dtype == SVt_PVGV) {
2494 SV *sref = SvREFCNT_inc(SvRV(sstr));
2496 int intro = GvINTRO(dstr);
2501 GvINTRO_off(dstr); /* one-shot flag */
2502 Newz(602,gp, 1, GP);
2503 GvGP(dstr) = gp_ref(gp);
2504 GvSV(dstr) = NEWSV(72,0);
2505 GvLINE(dstr) = CopLINE(PL_curcop);
2506 GvEGV(dstr) = (GV*)dstr;
2509 switch (SvTYPE(sref)) {
2512 SAVESPTR(GvAV(dstr));
2514 dref = (SV*)GvAV(dstr);
2515 GvAV(dstr) = (AV*)sref;
2516 if (GvIMPORTED_AV_off(dstr)
2517 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2519 GvIMPORTED_AV_on(dstr);
2524 SAVESPTR(GvHV(dstr));
2526 dref = (SV*)GvHV(dstr);
2527 GvHV(dstr) = (HV*)sref;
2528 if (GvIMPORTED_HV_off(dstr)
2529 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2531 GvIMPORTED_HV_on(dstr);
2536 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2537 SvREFCNT_dec(GvCV(dstr));
2538 GvCV(dstr) = Nullcv;
2539 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2540 PL_sub_generation++;
2542 SAVESPTR(GvCV(dstr));
2545 dref = (SV*)GvCV(dstr);
2546 if (GvCV(dstr) != (CV*)sref) {
2547 CV* cv = GvCV(dstr);
2549 if (!GvCVGEN((GV*)dstr) &&
2550 (CvROOT(cv) || CvXSUB(cv)))
2552 SV *const_sv = cv_const_sv(cv);
2553 bool const_changed = TRUE;
2555 const_changed = sv_cmp(const_sv,
2556 op_const_sv(CvSTART((CV*)sref),
2558 /* ahem, death to those who redefine
2559 * active sort subs */
2560 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2561 PL_sortcop == CvSTART(cv))
2563 "Can't redefine active sort subroutine %s",
2564 GvENAME((GV*)dstr));
2565 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2566 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2567 && HvNAME(GvSTASH(CvGV(cv)))
2568 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2570 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2571 "Constant subroutine %s redefined"
2572 : "Subroutine %s redefined",
2573 GvENAME((GV*)dstr));
2576 cv_ckproto(cv, (GV*)dstr,
2577 SvPOK(sref) ? SvPVX(sref) : Nullch);
2579 GvCV(dstr) = (CV*)sref;
2580 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2581 GvASSUMECV_on(dstr);
2582 PL_sub_generation++;
2584 if (GvIMPORTED_CV_off(dstr)
2585 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2587 GvIMPORTED_CV_on(dstr);
2592 SAVESPTR(GvIOp(dstr));
2594 dref = (SV*)GvIOp(dstr);
2595 GvIOp(dstr) = (IO*)sref;
2599 SAVESPTR(GvSV(dstr));
2601 dref = (SV*)GvSV(dstr);
2603 if (GvIMPORTED_SV_off(dstr)
2604 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2606 GvIMPORTED_SV_on(dstr);
2618 (void)SvOOK_off(dstr); /* backoff */
2620 Safefree(SvPVX(dstr));
2621 SvLEN(dstr)=SvCUR(dstr)=0;
2624 (void)SvOK_off(dstr);
2625 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2627 if (sflags & SVp_NOK) {
2629 SvNVX(dstr) = SvNVX(sstr);
2631 if (sflags & SVp_IOK) {
2632 (void)SvIOK_on(dstr);
2633 SvIVX(dstr) = SvIVX(sstr);
2637 if (SvAMAGIC(sstr)) {
2641 else if (sflags & SVp_POK) {
2644 * Check to see if we can just swipe the string. If so, it's a
2645 * possible small lose on short strings, but a big win on long ones.
2646 * It might even be a win on short strings if SvPVX(dstr)
2647 * has to be allocated and SvPVX(sstr) has to be freed.
2650 if (SvTEMP(sstr) && /* slated for free anyway? */
2651 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2652 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2654 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2656 SvFLAGS(dstr) &= ~SVf_OOK;
2657 Safefree(SvPVX(dstr) - SvIVX(dstr));
2659 else if (SvLEN(dstr))
2660 Safefree(SvPVX(dstr));
2662 (void)SvPOK_only(dstr);
2663 SvPV_set(dstr, SvPVX(sstr));
2664 SvLEN_set(dstr, SvLEN(sstr));
2665 SvCUR_set(dstr, SvCUR(sstr));
2667 (void)SvOK_off(sstr);
2668 SvPV_set(sstr, Nullch);
2673 else { /* have to copy actual string */
2674 STRLEN len = SvCUR(sstr);
2676 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2677 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2678 SvCUR_set(dstr, len);
2679 *SvEND(dstr) = '\0';
2680 (void)SvPOK_only(dstr);
2685 if (sflags & SVp_NOK) {
2687 SvNVX(dstr) = SvNVX(sstr);
2689 if (sflags & SVp_IOK) {
2690 (void)SvIOK_on(dstr);
2691 SvIVX(dstr) = SvIVX(sstr);
2696 else if (sflags & SVp_NOK) {
2697 SvNVX(dstr) = SvNVX(sstr);
2698 (void)SvNOK_only(dstr);
2700 (void)SvIOK_on(dstr);
2701 SvIVX(dstr) = SvIVX(sstr);
2702 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2707 else if (sflags & SVp_IOK) {
2708 (void)SvIOK_only(dstr);
2709 SvIVX(dstr) = SvIVX(sstr);
2714 if (dtype == SVt_PVGV) {
2715 if (ckWARN(WARN_UNSAFE))
2716 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2719 (void)SvOK_off(dstr);
2725 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2727 sv_setsv(dstr,sstr);
2732 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2734 register char *dptr;
2735 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2736 elicit a warning, but it won't hurt. */
2737 SV_CHECK_THINKFIRST(sv);
2742 (void)SvUPGRADE(sv, SVt_PV);
2744 SvGROW(sv, len + 1);
2746 Move(ptr,dptr,len,char);
2749 (void)SvPOK_only(sv); /* validate pointer */
2754 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2756 sv_setpvn(sv,ptr,len);
2761 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2763 register STRLEN len;
2765 SV_CHECK_THINKFIRST(sv);
2771 (void)SvUPGRADE(sv, SVt_PV);
2773 SvGROW(sv, len + 1);
2774 Move(ptr,SvPVX(sv),len+1,char);
2776 (void)SvPOK_only(sv); /* validate pointer */
2781 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2788 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2790 SV_CHECK_THINKFIRST(sv);
2791 (void)SvUPGRADE(sv, SVt_PV);
2796 (void)SvOOK_off(sv);
2797 if (SvPVX(sv) && SvLEN(sv))
2798 Safefree(SvPVX(sv));
2799 Renew(ptr, len+1, char);
2802 SvLEN_set(sv, len+1);
2804 (void)SvPOK_only(sv); /* validate pointer */
2809 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2811 sv_usepvn(sv,ptr,len);
2816 Perl_sv_force_normal(pTHX_ register SV *sv)
2818 if (SvREADONLY(sv)) {
2820 if (PL_curcop != &PL_compiling)
2821 Perl_croak(aTHX_ PL_no_modify);
2825 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2830 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2834 register STRLEN delta;
2836 if (!ptr || !SvPOKp(sv))
2838 SV_CHECK_THINKFIRST(sv);
2839 if (SvTYPE(sv) < SVt_PVIV)
2840 sv_upgrade(sv,SVt_PVIV);
2843 if (!SvLEN(sv)) { /* make copy of shared string */
2844 char *pvx = SvPVX(sv);
2845 STRLEN len = SvCUR(sv);
2846 SvGROW(sv, len + 1);
2847 Move(pvx,SvPVX(sv),len,char);
2851 SvFLAGS(sv) |= SVf_OOK;
2853 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2854 delta = ptr - SvPVX(sv);
2862 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2867 junk = SvPV_force(sv, tlen);
2868 SvGROW(sv, tlen + len + 1);
2871 Move(ptr,SvPVX(sv)+tlen,len,char);
2874 (void)SvPOK_only(sv); /* validate pointer */
2879 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2881 sv_catpvn(sv,ptr,len);
2886 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2892 if (s = SvPV(sstr, len))
2893 sv_catpvn(dstr,s,len);
2897 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2899 sv_catsv(dstr,sstr);
2904 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2906 register STRLEN len;
2912 junk = SvPV_force(sv, tlen);
2914 SvGROW(sv, tlen + len + 1);
2917 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2919 (void)SvPOK_only(sv); /* validate pointer */
2924 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2931 Perl_newSV(pTHX_ STRLEN len)
2937 sv_upgrade(sv, SVt_PV);
2938 SvGROW(sv, len + 1);
2943 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2946 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2950 if (SvREADONLY(sv)) {
2952 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2953 Perl_croak(aTHX_ PL_no_modify);
2955 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2956 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2963 (void)SvUPGRADE(sv, SVt_PVMG);
2965 Newz(702,mg, 1, MAGIC);
2966 mg->mg_moremagic = SvMAGIC(sv);
2969 if (!obj || obj == sv || how == '#' || how == 'r')
2973 mg->mg_obj = SvREFCNT_inc(obj);
2974 mg->mg_flags |= MGf_REFCOUNTED;
2977 mg->mg_len = namlen;
2980 mg->mg_ptr = savepvn(name, namlen);
2981 else if (namlen == HEf_SVKEY)
2982 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2986 mg->mg_virtual = &PL_vtbl_sv;
2989 mg->mg_virtual = &PL_vtbl_amagic;
2992 mg->mg_virtual = &PL_vtbl_amagicelem;
2998 mg->mg_virtual = &PL_vtbl_bm;
3001 mg->mg_virtual = &PL_vtbl_regdata;
3004 mg->mg_virtual = &PL_vtbl_regdatum;
3007 mg->mg_virtual = &PL_vtbl_env;
3010 mg->mg_virtual = &PL_vtbl_fm;
3013 mg->mg_virtual = &PL_vtbl_envelem;
3016 mg->mg_virtual = &PL_vtbl_mglob;
3019 mg->mg_virtual = &PL_vtbl_isa;
3022 mg->mg_virtual = &PL_vtbl_isaelem;
3025 mg->mg_virtual = &PL_vtbl_nkeys;
3032 mg->mg_virtual = &PL_vtbl_dbline;
3036 mg->mg_virtual = &PL_vtbl_mutex;
3038 #endif /* USE_THREADS */
3039 #ifdef USE_LOCALE_COLLATE
3041 mg->mg_virtual = &PL_vtbl_collxfrm;
3043 #endif /* USE_LOCALE_COLLATE */
3045 mg->mg_virtual = &PL_vtbl_pack;
3049 mg->mg_virtual = &PL_vtbl_packelem;
3052 mg->mg_virtual = &PL_vtbl_regexp;
3055 mg->mg_virtual = &PL_vtbl_sig;
3058 mg->mg_virtual = &PL_vtbl_sigelem;
3061 mg->mg_virtual = &PL_vtbl_taint;
3065 mg->mg_virtual = &PL_vtbl_uvar;
3068 mg->mg_virtual = &PL_vtbl_vec;
3071 mg->mg_virtual = &PL_vtbl_substr;
3074 mg->mg_virtual = &PL_vtbl_defelem;
3077 mg->mg_virtual = &PL_vtbl_glob;
3080 mg->mg_virtual = &PL_vtbl_arylen;
3083 mg->mg_virtual = &PL_vtbl_pos;
3086 mg->mg_virtual = &PL_vtbl_backref;
3088 case '~': /* Reserved for use by extensions not perl internals. */
3089 /* Useful for attaching extension internal data to perl vars. */
3090 /* Note that multiple extensions may clash if magical scalars */
3091 /* etc holding private data from one are passed to another. */
3095 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3099 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3103 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3107 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3110 for (mg = *mgp; mg; mg = *mgp) {
3111 if (mg->mg_type == type) {
3112 MGVTBL* vtbl = mg->mg_virtual;
3113 *mgp = mg->mg_moremagic;
3114 if (vtbl && vtbl->svt_free)
3115 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3116 if (mg->mg_ptr && mg->mg_type != 'g')
3117 if (mg->mg_len >= 0)
3118 Safefree(mg->mg_ptr);
3119 else if (mg->mg_len == HEf_SVKEY)
3120 SvREFCNT_dec((SV*)mg->mg_ptr);
3121 if (mg->mg_flags & MGf_REFCOUNTED)
3122 SvREFCNT_dec(mg->mg_obj);
3126 mgp = &mg->mg_moremagic;
3130 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3137 Perl_sv_rvweaken(pTHX_ SV *sv)
3140 if (!SvOK(sv)) /* let undefs pass */
3143 Perl_croak(aTHX_ "Can't weaken a nonreference");
3144 else if (SvWEAKREF(sv)) {
3146 if (ckWARN(WARN_MISC))
3147 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3151 sv_add_backref(tsv, sv);
3158 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3162 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3163 av = (AV*)mg->mg_obj;
3166 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3167 SvREFCNT_dec(av); /* for sv_magic */
3173 S_sv_del_backref(pTHX_ SV *sv)
3180 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3181 Perl_croak(aTHX_ "panic: del_backref");
3182 av = (AV *)mg->mg_obj;
3187 svp[i] = &PL_sv_undef; /* XXX */
3194 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3198 register char *midend;
3199 register char *bigend;
3205 Perl_croak(aTHX_ "Can't modify non-existent substring");
3206 SvPV_force(bigstr, curlen);
3207 if (offset + len > curlen) {
3208 SvGROW(bigstr, offset+len+1);
3209 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3210 SvCUR_set(bigstr, offset+len);
3214 i = littlelen - len;
3215 if (i > 0) { /* string might grow */
3216 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3217 mid = big + offset + len;
3218 midend = bigend = big + SvCUR(bigstr);
3221 while (midend > mid) /* shove everything down */
3222 *--bigend = *--midend;
3223 Move(little,big+offset,littlelen,char);
3229 Move(little,SvPVX(bigstr)+offset,len,char);
3234 big = SvPVX(bigstr);
3237 bigend = big + SvCUR(bigstr);
3239 if (midend > bigend)
3240 Perl_croak(aTHX_ "panic: sv_insert");
3242 if (mid - big > bigend - midend) { /* faster to shorten from end */
3244 Move(little, mid, littlelen,char);
3247 i = bigend - midend;
3249 Move(midend, mid, i,char);
3253 SvCUR_set(bigstr, mid - big);
3256 else if (i = mid - big) { /* faster from front */
3257 midend -= littlelen;
3259 sv_chop(bigstr,midend-i);
3264 Move(little, mid, littlelen,char);
3266 else if (littlelen) {
3267 midend -= littlelen;
3268 sv_chop(bigstr,midend);
3269 Move(little,midend,littlelen,char);
3272 sv_chop(bigstr,midend);
3277 /* make sv point to what nstr did */
3280 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3283 U32 refcnt = SvREFCNT(sv);
3284 SV_CHECK_THINKFIRST(sv);
3285 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3286 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3287 if (SvMAGICAL(sv)) {
3291 sv_upgrade(nsv, SVt_PVMG);
3292 SvMAGIC(nsv) = SvMAGIC(sv);
3293 SvFLAGS(nsv) |= SvMAGICAL(sv);
3299 assert(!SvREFCNT(sv));
3300 StructCopy(nsv,sv,SV);
3301 SvREFCNT(sv) = refcnt;
3302 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3307 Perl_sv_clear(pTHX_ register SV *sv)
3311 assert(SvREFCNT(sv) == 0);
3315 if (PL_defstash) { /* Still have a symbol table? */
3320 Zero(&tmpref, 1, SV);
3321 sv_upgrade(&tmpref, SVt_RV);
3323 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3324 SvREFCNT(&tmpref) = 1;
3327 stash = SvSTASH(sv);
3328 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3331 PUSHSTACKi(PERLSI_DESTROY);
3332 SvRV(&tmpref) = SvREFCNT_inc(sv);
3337 call_sv((SV*)GvCV(destructor),
3338 G_DISCARD|G_EVAL|G_KEEPERR);
3344 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3346 del_XRV(SvANY(&tmpref));
3349 if (PL_in_clean_objs)
3350 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3352 /* DESTROY gave object new lease on life */
3358 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3359 SvOBJECT_off(sv); /* Curse the object. */
3360 if (SvTYPE(sv) != SVt_PVIO)
3361 --PL_sv_objcount; /* XXX Might want something more general */
3364 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3367 switch (SvTYPE(sv)) {
3370 IoIFP(sv) != PerlIO_stdin() &&
3371 IoIFP(sv) != PerlIO_stdout() &&
3372 IoIFP(sv) != PerlIO_stderr())
3374 io_close((IO*)sv, FALSE);
3376 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3377 PerlDir_close(IoDIRP(sv));
3378 IoDIRP(sv) = (DIR*)NULL;
3379 Safefree(IoTOP_NAME(sv));
3380 Safefree(IoFMT_NAME(sv));
3381 Safefree(IoBOTTOM_NAME(sv));
3396 SvREFCNT_dec(LvTARG(sv));
3400 Safefree(GvNAME(sv));
3401 /* cannot decrease stash refcount yet, as we might recursively delete
3402 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3403 of stash until current sv is completely gone.
3404 -- JohnPC, 27 Mar 1998 */
3405 stash = GvSTASH(sv);
3411 (void)SvOOK_off(sv);
3419 SvREFCNT_dec(SvRV(sv));
3421 else if (SvPVX(sv) && SvLEN(sv))
3422 Safefree(SvPVX(sv));
3432 switch (SvTYPE(sv)) {
3448 del_XPVIV(SvANY(sv));
3451 del_XPVNV(SvANY(sv));
3454 del_XPVMG(SvANY(sv));
3457 del_XPVLV(SvANY(sv));
3460 del_XPVAV(SvANY(sv));
3463 del_XPVHV(SvANY(sv));
3466 del_XPVCV(SvANY(sv));
3469 del_XPVGV(SvANY(sv));
3470 /* code duplication for increased performance. */
3471 SvFLAGS(sv) &= SVf_BREAK;
3472 SvFLAGS(sv) |= SVTYPEMASK;
3473 /* decrease refcount of the stash that owns this GV, if any */
3475 SvREFCNT_dec(stash);
3476 return; /* not break, SvFLAGS reset already happened */
3478 del_XPVBM(SvANY(sv));
3481 del_XPVFM(SvANY(sv));
3484 del_XPVIO(SvANY(sv));
3487 SvFLAGS(sv) &= SVf_BREAK;
3488 SvFLAGS(sv) |= SVTYPEMASK;
3492 Perl_sv_newref(pTHX_ SV *sv)
3495 ATOMIC_INC(SvREFCNT(sv));
3500 Perl_sv_free(pTHX_ SV *sv)
3503 int refcount_is_zero;
3507 if (SvREFCNT(sv) == 0) {
3508 if (SvFLAGS(sv) & SVf_BREAK)
3510 if (PL_in_clean_all) /* All is fair */
3512 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3513 /* make sure SvREFCNT(sv)==0 happens very seldom */
3514 SvREFCNT(sv) = (~(U32)0)/2;
3517 if (ckWARN_d(WARN_INTERNAL))
3518 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3521 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3522 if (!refcount_is_zero)
3526 if (ckWARN_d(WARN_DEBUGGING))
3527 Perl_warner(aTHX_ WARN_DEBUGGING,
3528 "Attempt to free temp prematurely: SV 0x%"UVxf,
3533 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3534 /* make sure SvREFCNT(sv)==0 happens very seldom */
3535 SvREFCNT(sv) = (~(U32)0)/2;
3544 Perl_sv_len(pTHX_ register SV *sv)
3553 len = mg_length(sv);
3555 junk = SvPV(sv, len);
3560 Perl_sv_len_utf8(pTHX_ register SV *sv)
3571 len = mg_length(sv);
3574 s = (U8*)SvPV(sv, len);
3585 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3590 I32 uoffset = *offsetp;
3596 start = s = (U8*)SvPV(sv, len);
3598 while (s < send && uoffset--)
3602 *offsetp = s - start;
3606 while (s < send && ulen--)
3616 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3625 s = (U8*)SvPV(sv, len);
3627 Perl_croak(aTHX_ "panic: bad byte offset");
3628 send = s + *offsetp;
3636 if (ckWARN_d(WARN_UTF8))
3637 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3645 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3657 pv1 = SvPV(str1, cur1);
3662 pv2 = SvPV(str2, cur2);
3667 return memEQ(pv1, pv2, cur1);
3671 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3674 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3676 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3680 return cur2 ? -1 : 0;
3685 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3688 return retval < 0 ? -1 : 1;
3693 return cur1 < cur2 ? -1 : 1;
3697 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3699 #ifdef USE_LOCALE_COLLATE
3705 if (PL_collation_standard)
3709 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3711 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3713 if (!pv1 || !len1) {
3724 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3727 return retval < 0 ? -1 : 1;
3730 * When the result of collation is equality, that doesn't mean
3731 * that there are no differences -- some locales exclude some
3732 * characters from consideration. So to avoid false equalities,
3733 * we use the raw string as a tiebreaker.
3739 #endif /* USE_LOCALE_COLLATE */
3741 return sv_cmp(sv1, sv2);
3744 #ifdef USE_LOCALE_COLLATE
3746 * Any scalar variable may carry an 'o' magic that contains the
3747 * scalar data of the variable transformed to such a format that
3748 * a normal memory comparison can be used to compare the data
3749 * according to the locale settings.
3752 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3756 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3757 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3762 Safefree(mg->mg_ptr);
3764 if ((xf = mem_collxfrm(s, len, &xlen))) {
3765 if (SvREADONLY(sv)) {
3768 return xf + sizeof(PL_collation_ix);
3771 sv_magic(sv, 0, 'o', 0, 0);
3772 mg = mg_find(sv, 'o');
3785 if (mg && mg->mg_ptr) {
3787 return mg->mg_ptr + sizeof(PL_collation_ix);
3795 #endif /* USE_LOCALE_COLLATE */
3798 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3803 register STDCHAR rslast;
3804 register STDCHAR *bp;
3808 SV_CHECK_THINKFIRST(sv);
3809 (void)SvUPGRADE(sv, SVt_PV);
3813 if (RsSNARF(PL_rs)) {
3817 else if (RsRECORD(PL_rs)) {
3818 I32 recsize, bytesread;
3821 /* Grab the size of the record we're getting */
3822 recsize = SvIV(SvRV(PL_rs));
3823 (void)SvPOK_only(sv); /* Validate pointer */
3824 buffer = SvGROW(sv, recsize + 1);
3827 /* VMS wants read instead of fread, because fread doesn't respect */
3828 /* RMS record boundaries. This is not necessarily a good thing to be */
3829 /* doing, but we've got no other real choice */
3830 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3832 bytesread = PerlIO_read(fp, buffer, recsize);
3834 SvCUR_set(sv, bytesread);
3835 buffer[bytesread] = '\0';
3836 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3838 else if (RsPARA(PL_rs)) {
3843 rsptr = SvPV(PL_rs, rslen);
3844 rslast = rslen ? rsptr[rslen - 1] : '\0';
3846 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3847 do { /* to make sure file boundaries work right */
3850 i = PerlIO_getc(fp);
3854 PerlIO_ungetc(fp,i);
3860 /* See if we know enough about I/O mechanism to cheat it ! */
3862 /* This used to be #ifdef test - it is made run-time test for ease
3863 of abstracting out stdio interface. One call should be cheap
3864 enough here - and may even be a macro allowing compile
3868 if (PerlIO_fast_gets(fp)) {
3871 * We're going to steal some values from the stdio struct
3872 * and put EVERYTHING in the innermost loop into registers.
3874 register STDCHAR *ptr;
3878 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3879 /* An ungetc()d char is handled separately from the regular
3880 * buffer, so we getc() it back out and stuff it in the buffer.
3882 i = PerlIO_getc(fp);
3883 if (i == EOF) return 0;
3884 *(--((*fp)->_ptr)) = (unsigned char) i;
3888 /* Here is some breathtakingly efficient cheating */
3890 cnt = PerlIO_get_cnt(fp); /* get count into register */
3891 (void)SvPOK_only(sv); /* validate pointer */
3892 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3893 if (cnt > 80 && SvLEN(sv) > append) {
3894 shortbuffered = cnt - SvLEN(sv) + append + 1;
3895 cnt -= shortbuffered;
3899 /* remember that cnt can be negative */
3900 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3905 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3906 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3907 DEBUG_P(PerlIO_printf(Perl_debug_log,
3908 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3909 DEBUG_P(PerlIO_printf(Perl_debug_log,
3910 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3911 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3912 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3917 while (cnt > 0) { /* this | eat */
3919 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3920 goto thats_all_folks; /* screams | sed :-) */
3924 Copy(ptr, bp, cnt, char); /* this | eat */
3925 bp += cnt; /* screams | dust */
3926 ptr += cnt; /* louder | sed :-) */
3931 if (shortbuffered) { /* oh well, must extend */
3932 cnt = shortbuffered;
3934 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3936 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3937 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3941 DEBUG_P(PerlIO_printf(Perl_debug_log,
3942 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
3943 PTR2UV(ptr),(long)cnt));
3944 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3945 DEBUG_P(PerlIO_printf(Perl_debug_log,
3946 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3947 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3948 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3949 /* This used to call 'filbuf' in stdio form, but as that behaves like
3950 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3951 another abstraction. */
3952 i = PerlIO_getc(fp); /* get more characters */
3953 DEBUG_P(PerlIO_printf(Perl_debug_log,
3954 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3955 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3956 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3957 cnt = PerlIO_get_cnt(fp);
3958 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3959 DEBUG_P(PerlIO_printf(Perl_debug_log,
3960 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3962 if (i == EOF) /* all done for ever? */
3963 goto thats_really_all_folks;
3965 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3967 SvGROW(sv, bpx + cnt + 2);
3968 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3970 *bp++ = i; /* store character from PerlIO_getc */
3972 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3973 goto thats_all_folks;
3977 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3978 memNE((char*)bp - rslen, rsptr, rslen))
3979 goto screamer; /* go back to the fray */
3980 thats_really_all_folks:
3982 cnt += shortbuffered;
3983 DEBUG_P(PerlIO_printf(Perl_debug_log,
3984 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3985 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3986 DEBUG_P(PerlIO_printf(Perl_debug_log,
3987 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3988 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3989 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3991 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3992 DEBUG_P(PerlIO_printf(Perl_debug_log,
3993 "Screamer: done, len=%ld, string=|%.*s|\n",
3994 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3999 /*The big, slow, and stupid way */
4002 /* Need to work around EPOC SDK features */
4003 /* On WINS: MS VC5 generates calls to _chkstk, */
4004 /* if a `large' stack frame is allocated */
4005 /* gcc on MARM does not generate calls like these */
4011 register STDCHAR *bpe = buf + sizeof(buf);
4013 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4014 ; /* keep reading */
4018 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4019 /* Accomodate broken VAXC compiler, which applies U8 cast to
4020 * both args of ?: operator, causing EOF to change into 255
4022 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4026 sv_catpvn(sv, (char *) buf, cnt);
4028 sv_setpvn(sv, (char *) buf, cnt);
4030 if (i != EOF && /* joy */
4032 SvCUR(sv) < rslen ||
4033 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4037 * If we're reading from a TTY and we get a short read,
4038 * indicating that the user hit his EOF character, we need
4039 * to notice it now, because if we try to read from the TTY
4040 * again, the EOF condition will disappear.
4042 * The comparison of cnt to sizeof(buf) is an optimization
4043 * that prevents unnecessary calls to feof().
4047 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4052 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4053 while (i != EOF) { /* to make sure file boundaries work right */
4054 i = PerlIO_getc(fp);
4056 PerlIO_ungetc(fp,i);
4062 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4067 Perl_sv_inc(pTHX_ register SV *sv)
4076 if (SvTHINKFIRST(sv)) {
4077 if (SvREADONLY(sv)) {
4079 if (PL_curcop != &PL_compiling)
4080 Perl_croak(aTHX_ PL_no_modify);
4084 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4086 i = PTR2IV(SvRV(sv));
4091 flags = SvFLAGS(sv);
4092 if (flags & SVp_NOK) {
4093 (void)SvNOK_only(sv);
4097 if (flags & SVp_IOK) {
4099 if (SvUVX(sv) == UV_MAX)
4100 sv_setnv(sv, (NV)UV_MAX + 1.0);
4102 (void)SvIOK_only_UV(sv);
4105 if (SvIVX(sv) == IV_MAX)
4106 sv_setnv(sv, (NV)IV_MAX + 1.0);
4108 (void)SvIOK_only(sv);
4114 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4115 if ((flags & SVTYPEMASK) < SVt_PVNV)
4116 sv_upgrade(sv, SVt_NV);
4118 (void)SvNOK_only(sv);
4122 while (isALPHA(*d)) d++;
4123 while (isDIGIT(*d)) d++;
4125 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4129 while (d >= SvPVX(sv)) {
4137 /* MKS: The original code here died if letters weren't consecutive.
4138 * at least it didn't have to worry about non-C locales. The
4139 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4140 * arranged in order (although not consecutively) and that only
4141 * [A-Za-z] are accepted by isALPHA in the C locale.
4143 if (*d != 'z' && *d != 'Z') {
4144 do { ++*d; } while (!isALPHA(*d));
4147 *(d--) -= 'z' - 'a';
4152 *(d--) -= 'z' - 'a' + 1;
4156 /* oh,oh, the number grew */
4157 SvGROW(sv, SvCUR(sv) + 2);
4159 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4168 Perl_sv_dec(pTHX_ register SV *sv)
4176 if (SvTHINKFIRST(sv)) {
4177 if (SvREADONLY(sv)) {
4179 if (PL_curcop != &PL_compiling)
4180 Perl_croak(aTHX_ PL_no_modify);
4184 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4186 i = PTR2IV(SvRV(sv));
4191 flags = SvFLAGS(sv);
4192 if (flags & SVp_NOK) {
4194 (void)SvNOK_only(sv);
4197 if (flags & SVp_IOK) {
4199 if (SvUVX(sv) == 0) {
4200 (void)SvIOK_only(sv);
4204 (void)SvIOK_only_UV(sv);
4208 if (SvIVX(sv) == IV_MIN)
4209 sv_setnv(sv, (NV)IV_MIN - 1.0);
4211 (void)SvIOK_only(sv);
4217 if (!(flags & SVp_POK)) {
4218 if ((flags & SVTYPEMASK) < SVt_PVNV)
4219 sv_upgrade(sv, SVt_NV);
4221 (void)SvNOK_only(sv);
4224 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4227 /* Make a string that will exist for the duration of the expression
4228 * evaluation. Actually, it may have to last longer than that, but
4229 * hopefully we won't free it until it has been assigned to a
4230 * permanent location. */
4233 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4239 sv_setsv(sv,oldstr);
4241 PL_tmps_stack[++PL_tmps_ix] = sv;
4247 Perl_sv_newmortal(pTHX)
4253 SvFLAGS(sv) = SVs_TEMP;
4255 PL_tmps_stack[++PL_tmps_ix] = sv;
4259 /* same thing without the copying */
4262 Perl_sv_2mortal(pTHX_ register SV *sv)
4267 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4270 PL_tmps_stack[++PL_tmps_ix] = sv;
4276 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4283 sv_setpvn(sv,s,len);
4288 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4293 sv_setpvn(sv,s,len);
4297 #if defined(PERL_IMPLICIT_CONTEXT)
4299 Perl_newSVpvf_nocontext(const char* pat, ...)
4304 va_start(args, pat);
4305 sv = vnewSVpvf(pat, &args);
4312 Perl_newSVpvf(pTHX_ const char* pat, ...)
4316 va_start(args, pat);
4317 sv = vnewSVpvf(pat, &args);
4323 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4327 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4332 Perl_newSVnv(pTHX_ NV n)
4342 Perl_newSViv(pTHX_ IV i)
4352 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4358 sv_upgrade(sv, SVt_RV);
4366 Perl_newRV(pTHX_ SV *tmpRef)
4368 return newRV_noinc(SvREFCNT_inc(tmpRef));
4371 /* make an exact duplicate of old */
4374 Perl_newSVsv(pTHX_ register SV *old)
4381 if (SvTYPE(old) == SVTYPEMASK) {
4382 if (ckWARN_d(WARN_INTERNAL))
4383 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4398 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4406 char todo[PERL_UCHAR_MAX+1];
4411 if (!*s) { /* reset ?? searches */
4412 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4413 pm->op_pmdynflags &= ~PMdf_USED;
4418 /* reset variables */
4420 if (!HvARRAY(stash))
4423 Zero(todo, 256, char);
4425 i = (unsigned char)*s;
4429 max = (unsigned char)*s++;
4430 for ( ; i <= max; i++) {
4433 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4434 for (entry = HvARRAY(stash)[i];
4436 entry = HeNEXT(entry))
4438 if (!todo[(U8)*HeKEY(entry)])
4440 gv = (GV*)HeVAL(entry);
4442 if (SvTHINKFIRST(sv)) {
4443 if (!SvREADONLY(sv) && SvROK(sv))
4448 if (SvTYPE(sv) >= SVt_PV) {
4450 if (SvPVX(sv) != Nullch)
4457 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4459 #ifndef VMS /* VMS has no environ array */
4461 environ[0] = Nullch;
4470 Perl_sv_2io(pTHX_ SV *sv)
4476 switch (SvTYPE(sv)) {
4484 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4488 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4490 return sv_2io(SvRV(sv));
4491 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4497 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4504 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4511 return *gvp = Nullgv, Nullcv;
4512 switch (SvTYPE(sv)) {
4532 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4533 tryAMAGICunDEREF(to_cv);
4536 if (SvTYPE(sv) == SVt_PVCV) {
4545 Perl_croak(aTHX_ "Not a subroutine reference");
4550 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4556 if (lref && !GvCVu(gv)) {
4559 tmpsv = NEWSV(704,0);
4560 gv_efullname3(tmpsv, gv, Nullch);
4561 /* XXX this is probably not what they think they're getting.
4562 * It has the same effect as "sub name;", i.e. just a forward
4564 newSUB(start_subparse(FALSE, 0),
4565 newSVOP(OP_CONST, 0, tmpsv),
4570 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4577 Perl_sv_true(pTHX_ register SV *sv)
4584 if ((tXpv = (XPV*)SvANY(sv)) &&
4585 (tXpv->xpv_cur > 1 ||
4586 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4593 return SvIVX(sv) != 0;
4596 return SvNVX(sv) != 0.0;
4598 return sv_2bool(sv);
4604 Perl_sv_iv(pTHX_ register SV *sv)
4608 return (IV)SvUVX(sv);
4615 Perl_sv_uv(pTHX_ register SV *sv)
4620 return (UV)SvIVX(sv);
4626 Perl_sv_nv(pTHX_ register SV *sv)
4634 Perl_sv_pv(pTHX_ SV *sv)
4641 return sv_2pv(sv, &n_a);
4645 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4651 return sv_2pv(sv, lp);
4655 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4659 if (SvTHINKFIRST(sv) && !SvROK(sv))
4660 sv_force_normal(sv);
4666 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4668 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4669 PL_op_name[PL_op->op_type]);
4673 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4678 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4679 SvGROW(sv, len + 1);
4680 Move(s,SvPVX(sv),len,char);
4685 SvPOK_on(sv); /* validate pointer */
4687 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
4688 PTR2UV(sv),SvPVX(sv)));
4695 Perl_sv_pvbyte(pTHX_ SV *sv)
4701 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
4703 return sv_pvn(sv,lp);
4707 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
4709 return sv_pvn_force(sv,lp);
4713 Perl_sv_pvutf8(pTHX_ SV *sv)
4719 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
4721 return sv_pvn(sv,lp);
4725 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
4727 return sv_pvn_force(sv,lp);
4731 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4733 if (ob && SvOBJECT(sv))
4734 return HvNAME(SvSTASH(sv));
4736 switch (SvTYPE(sv)) {
4750 case SVt_PVLV: return "LVALUE";
4751 case SVt_PVAV: return "ARRAY";
4752 case SVt_PVHV: return "HASH";
4753 case SVt_PVCV: return "CODE";
4754 case SVt_PVGV: return "GLOB";
4755 case SVt_PVFM: return "FORMAT";
4756 default: return "UNKNOWN";
4762 Perl_sv_isobject(pTHX_ SV *sv)
4777 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4789 return strEQ(HvNAME(SvSTASH(sv)), name);
4793 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4800 SV_CHECK_THINKFIRST(rv);
4803 if (SvTYPE(rv) < SVt_RV)
4804 sv_upgrade(rv, SVt_RV);
4811 HV* stash = gv_stashpv(classname, TRUE);
4812 (void)sv_bless(rv, stash);
4818 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4821 sv_setsv(rv, &PL_sv_undef);
4825 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4830 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4832 sv_setiv(newSVrv(rv,classname), iv);
4837 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4839 sv_setnv(newSVrv(rv,classname), nv);
4844 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4846 sv_setpvn(newSVrv(rv,classname), pv, n);
4851 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4856 Perl_croak(aTHX_ "Can't bless non-reference value");
4858 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4859 if (SvREADONLY(tmpRef))
4860 Perl_croak(aTHX_ PL_no_modify);
4861 if (SvOBJECT(tmpRef)) {
4862 if (SvTYPE(tmpRef) != SVt_PVIO)
4864 SvREFCNT_dec(SvSTASH(tmpRef));
4867 SvOBJECT_on(tmpRef);
4868 if (SvTYPE(tmpRef) != SVt_PVIO)
4870 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4871 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4882 S_sv_unglob(pTHX_ SV *sv)
4884 assert(SvTYPE(sv) == SVt_PVGV);
4889 SvREFCNT_dec(GvSTASH(sv));
4890 GvSTASH(sv) = Nullhv;
4892 sv_unmagic(sv, '*');
4893 Safefree(GvNAME(sv));
4895 SvFLAGS(sv) &= ~SVTYPEMASK;
4896 SvFLAGS(sv) |= SVt_PVMG;
4900 Perl_sv_unref(pTHX_ SV *sv)
4904 if (SvWEAKREF(sv)) {
4912 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4915 sv_2mortal(rv); /* Schedule for freeing later */
4919 Perl_sv_taint(pTHX_ SV *sv)
4921 sv_magic((sv), Nullsv, 't', Nullch, 0);
4925 Perl_sv_untaint(pTHX_ SV *sv)
4927 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4928 MAGIC *mg = mg_find(sv, 't');
4935 Perl_sv_tainted(pTHX_ SV *sv)
4937 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4938 MAGIC *mg = mg_find(sv, 't');
4939 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4946 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4948 char buf[TYPE_CHARS(UV)];
4950 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4952 sv_setpvn(sv, ptr, ebuf - ptr);
4957 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4959 char buf[TYPE_CHARS(UV)];
4961 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4963 sv_setpvn(sv, ptr, ebuf - ptr);
4967 #if defined(PERL_IMPLICIT_CONTEXT)
4969 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4973 va_start(args, pat);
4974 sv_vsetpvf(sv, pat, &args);
4980 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4984 va_start(args, pat);
4985 sv_vsetpvf_mg(sv, pat, &args);
4991 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4994 va_start(args, pat);
4995 sv_vsetpvf(sv, pat, &args);
5000 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5002 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5006 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5009 va_start(args, pat);
5010 sv_vsetpvf_mg(sv, pat, &args);
5015 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5017 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5021 #if defined(PERL_IMPLICIT_CONTEXT)
5023 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5027 va_start(args, pat);
5028 sv_vcatpvf(sv, pat, &args);
5033 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5037 va_start(args, pat);
5038 sv_vcatpvf_mg(sv, pat, &args);
5044 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5047 va_start(args, pat);
5048 sv_vcatpvf(sv, pat, &args);
5053 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5055 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5059 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5062 va_start(args, pat);
5063 sv_vcatpvf_mg(sv, pat, &args);
5068 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5070 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5075 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5077 sv_setpvn(sv, "", 0);
5078 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5082 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5090 static char nullstr[] = "(null)";
5092 /* no matter what, this is a string now */
5093 (void)SvPV_force(sv, origlen);
5095 /* special-case "", "%s", and "%_" */
5098 if (patlen == 2 && pat[0] == '%') {
5102 char *s = va_arg(*args, char*);
5103 sv_catpv(sv, s ? s : nullstr);
5105 else if (svix < svmax)
5106 sv_catsv(sv, *svargs);
5110 sv_catsv(sv, va_arg(*args, SV*));
5113 /* See comment on '_' below */
5118 patend = (char*)pat + patlen;
5119 for (p = (char*)pat; p < patend; p = q) {
5127 bool has_precis = FALSE;
5132 STRLEN esignlen = 0;
5134 char *eptr = Nullch;
5136 /* Times 4: a decimal digit takes more than 3 binary digits.
5137 * NV_DIG: mantissa takes than many decimal digits.
5138 * Plus 32: Playing safe. */
5139 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5140 /* large enough for "%#.#f" --chip */
5141 /* what about long double NVs? --jhi */
5152 for (q = p; q < patend && *q != '%'; ++q) ;
5154 sv_catpvn(sv, p, q - p);
5192 case '1': case '2': case '3':
5193 case '4': case '5': case '6':
5194 case '7': case '8': case '9':
5197 width = width * 10 + (*q++ - '0');
5202 i = va_arg(*args, int);
5204 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5206 width = (i < 0) ? -i : i;
5217 i = va_arg(*args, int);
5219 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5220 precis = (i < 0) ? 0 : i;
5226 precis = precis * 10 + (*q++ - '0');
5243 if (*(q + 1) == 'l') { /* lld */
5271 uv = va_arg(*args, int);
5273 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5275 eptr = (char*)utf8buf;
5276 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5280 c = va_arg(*args, int);
5282 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5289 eptr = va_arg(*args, char*);
5291 #ifdef MACOS_TRADITIONAL
5292 /* On MacOS, %#s format is used for Pascal strings */
5297 elen = strlen(eptr);
5300 elen = sizeof nullstr - 1;
5303 else if (svix < svmax) {
5304 eptr = SvPVx(svargs[svix++], elen);
5306 if (has_precis && precis < elen) {
5308 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5311 if (width) { /* fudge width (can't fudge elen) */
5312 width += elen - sv_len_utf8(svargs[svix - 1]);
5320 * The "%_" hack might have to be changed someday,
5321 * if ISO or ANSI decide to use '_' for something.
5322 * So we keep it hidden from users' code.
5326 eptr = SvPVx(va_arg(*args, SV*), elen);
5329 if (has_precis && elen > precis)
5337 uv = PTR2UV(va_arg(*args, void*));
5339 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5354 case 'h': iv = (short)va_arg(*args, int); break;
5355 default: iv = va_arg(*args, int); break;
5356 case 'l': iv = va_arg(*args, long); break;
5357 case 'V': iv = va_arg(*args, IV); break;
5359 case 'q': iv = va_arg(*args, Quad_t); break;
5364 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5366 case 'h': iv = (short)iv; break;
5367 default: iv = (int)iv; break;
5368 case 'l': iv = (long)iv; break;
5371 case 'q': iv = (Quad_t)iv; break;
5378 esignbuf[esignlen++] = plus;
5382 esignbuf[esignlen++] = '-';
5420 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5421 default: uv = va_arg(*args, unsigned); break;
5422 case 'l': uv = va_arg(*args, unsigned long); break;
5423 case 'V': uv = va_arg(*args, UV); break;
5425 case 'q': uv = va_arg(*args, Quad_t); break;
5430 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5432 case 'h': uv = (unsigned short)uv; break;
5433 default: uv = (unsigned)uv; break;
5434 case 'l': uv = (unsigned long)uv; break;
5437 case 'q': uv = (Quad_t)uv; break;
5443 eptr = ebuf + sizeof ebuf;
5449 p = (char*)((c == 'X')
5450 ? "0123456789ABCDEF" : "0123456789abcdef");
5456 esignbuf[esignlen++] = '0';
5457 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5463 *--eptr = '0' + dig;
5465 if (alt && *eptr != '0')
5471 *--eptr = '0' + dig;
5474 esignbuf[esignlen++] = '0';
5475 esignbuf[esignlen++] = 'b';
5478 default: /* it had better be ten or less */
5479 #if defined(PERL_Y2KWARN)
5480 if (ckWARN(WARN_MISC)) {
5482 char *s = SvPV(sv,n);
5483 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5484 && (n == 2 || !isDIGIT(s[n-3])))
5486 Perl_warner(aTHX_ WARN_MISC,
5487 "Possible Y2K bug: %%%c %s",
5488 c, "format string following '19'");
5494 *--eptr = '0' + dig;
5495 } while (uv /= base);
5498 elen = (ebuf + sizeof ebuf) - eptr;
5501 zeros = precis - elen;
5502 else if (precis == 0 && elen == 1 && *eptr == '0')
5507 /* FLOATING POINT */
5510 c = 'f'; /* maybe %F isn't supported here */
5516 /* This is evil, but floating point is even more evil */
5519 nv = va_arg(*args, NV);
5521 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5524 if (c != 'e' && c != 'E') {
5526 (void)frexp(nv, &i);
5527 if (i == PERL_INT_MIN)
5528 Perl_die(aTHX_ "panic: frexp");
5530 need = BIT_DIGITS(i);
5532 need += has_precis ? precis : 6; /* known default */
5536 need += 20; /* fudge factor */
5537 if (PL_efloatsize < need) {
5538 Safefree(PL_efloatbuf);
5539 PL_efloatsize = need + 20; /* more fudge */
5540 New(906, PL_efloatbuf, PL_efloatsize, char);
5541 PL_efloatbuf[0] = '\0';
5544 eptr = ebuf + sizeof ebuf;
5547 #ifdef USE_LONG_DOUBLE
5549 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5550 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5555 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5560 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5573 RESTORE_NUMERIC_STANDARD();
5574 (void)sprintf(PL_efloatbuf, eptr, nv);
5575 RESTORE_NUMERIC_LOCAL();
5578 eptr = PL_efloatbuf;
5579 elen = strlen(PL_efloatbuf);
5585 i = SvCUR(sv) - origlen;
5588 case 'h': *(va_arg(*args, short*)) = i; break;
5589 default: *(va_arg(*args, int*)) = i; break;
5590 case 'l': *(va_arg(*args, long*)) = i; break;
5591 case 'V': *(va_arg(*args, IV*)) = i; break;
5593 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5597 else if (svix < svmax)
5598 sv_setuv(svargs[svix++], (UV)i);
5599 continue; /* not "break" */
5605 if (!args && ckWARN(WARN_PRINTF) &&
5606 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5607 SV *msg = sv_newmortal();
5608 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5609 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5612 Perl_sv_catpvf(aTHX_ msg,
5613 "\"%%%c\"", c & 0xFF);
5615 Perl_sv_catpvf(aTHX_ msg,
5616 "\"%%\\%03"UVof"\"",
5619 sv_catpv(msg, "end of string");
5620 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5623 /* output mangled stuff ... */
5629 /* ... right here, because formatting flags should not apply */
5630 SvGROW(sv, SvCUR(sv) + elen + 1);
5632 memcpy(p, eptr, elen);
5635 SvCUR(sv) = p - SvPVX(sv);
5636 continue; /* not "break" */
5639 have = esignlen + zeros + elen;
5640 need = (have > width ? have : width);
5643 SvGROW(sv, SvCUR(sv) + need + 1);
5645 if (esignlen && fill == '0') {
5646 for (i = 0; i < esignlen; i++)
5650 memset(p, fill, gap);
5653 if (esignlen && fill != '0') {
5654 for (i = 0; i < esignlen; i++)
5658 for (i = zeros; i; i--)
5662 memcpy(p, eptr, elen);
5666 memset(p, ' ', gap);
5670 SvCUR(sv) = p - SvPVX(sv);
5674 #if defined(USE_ITHREADS)
5676 #if defined(USE_THREADS)
5677 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
5680 #ifndef OpREFCNT_inc
5681 # define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop)
5684 #ifndef GpREFCNT_inc
5685 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
5689 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
5690 #define av_dup(s) (AV*)sv_dup((SV*)s)
5691 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
5692 #define hv_dup(s) (HV*)sv_dup((SV*)s)
5693 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
5694 #define cv_dup(s) (CV*)sv_dup((SV*)s)
5695 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
5696 #define io_dup(s) (IO*)sv_dup((SV*)s)
5697 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
5698 #define gv_dup(s) (GV*)sv_dup((SV*)s)
5699 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
5700 #define SAVEPV(p) (p ? savepv(p) : Nullch)
5701 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
5704 Perl_re_dup(pTHX_ REGEXP *r)
5706 /* XXX fix when pmop->op_pmregexp becomes shared */
5707 return ReREFCNT_inc(r);
5711 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
5715 return (PerlIO*)NULL;
5717 /* look for it in the table first */
5718 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
5722 /* create anew and remember what it is */
5723 ret = PerlIO_fdupopen(fp);
5724 ptr_table_store(PL_ptr_table, fp, ret);
5729 Perl_dirp_dup(pTHX_ DIR *dp)
5738 Perl_gp_dup(pTHX_ GP *gp)
5743 /* look for it in the table first */
5744 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
5748 /* create anew and remember what it is */
5749 Newz(0, ret, 1, GP);
5750 ptr_table_store(PL_ptr_table, gp, ret);
5753 ret->gp_refcnt = 0; /* must be before any other dups! */
5754 ret->gp_sv = sv_dup_inc(gp->gp_sv);
5755 ret->gp_io = io_dup_inc(gp->gp_io);
5756 ret->gp_form = cv_dup_inc(gp->gp_form);
5757 ret->gp_av = av_dup_inc(gp->gp_av);
5758 ret->gp_hv = hv_dup_inc(gp->gp_hv);
5759 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
5760 ret->gp_cv = cv_dup_inc(gp->gp_cv);
5761 ret->gp_cvgen = gp->gp_cvgen;
5762 ret->gp_flags = gp->gp_flags;
5763 ret->gp_line = gp->gp_line;
5764 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
5769 Perl_mg_dup(pTHX_ MAGIC *mg)
5771 MAGIC *mgret = (MAGIC*)NULL;
5774 return (MAGIC*)NULL;
5775 /* look for it in the table first */
5776 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
5780 for (; mg; mg = mg->mg_moremagic) {
5782 Newz(0, nmg, 1, MAGIC);
5786 mgprev->mg_moremagic = nmg;
5787 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
5788 nmg->mg_private = mg->mg_private;
5789 nmg->mg_type = mg->mg_type;
5790 nmg->mg_flags = mg->mg_flags;
5791 if (mg->mg_type == 'r') {
5792 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5795 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5796 ? sv_dup_inc(mg->mg_obj)
5797 : sv_dup(mg->mg_obj);
5799 nmg->mg_len = mg->mg_len;
5800 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
5801 if (mg->mg_ptr && mg->mg_type != 'g') {
5802 if (mg->mg_len >= 0) {
5803 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
5804 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
5805 AMT *amtp = (AMT*)mg->mg_ptr;
5806 AMT *namtp = (AMT*)nmg->mg_ptr;
5808 for (i = 1; i < NofAMmeth; i++) {
5809 namtp->table[i] = cv_dup_inc(amtp->table[i]);
5813 else if (mg->mg_len == HEf_SVKEY)
5814 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
5822 Perl_ptr_table_new(pTHX)
5825 Newz(0, tbl, 1, PTR_TBL_t);
5828 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
5833 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
5835 PTR_TBL_ENT_t *tblent;
5838 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5839 for (; tblent; tblent = tblent->next) {
5840 if (tblent->oldval == sv)
5841 return tblent->newval;
5847 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
5849 PTR_TBL_ENT_t *tblent, **otblent;
5850 /* XXX this may be pessimal on platforms where pointers aren't good
5851 * hash values e.g. if they grow faster in the most significant
5857 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5858 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5859 if (tblent->oldval == oldv) {
5860 tblent->newval = newv;
5865 Newz(0, tblent, 1, PTR_TBL_ENT_t);
5866 tblent->oldval = oldv;
5867 tblent->newval = newv;
5868 tblent->next = *otblent;
5871 if (i && tbl->tbl_items > tbl->tbl_max)
5872 ptr_table_split(tbl);
5876 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
5878 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
5879 UV oldsize = tbl->tbl_max + 1;
5880 UV newsize = oldsize * 2;
5883 Renew(ary, newsize, PTR_TBL_ENT_t*);
5884 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
5885 tbl->tbl_max = --newsize;
5887 for (i=0; i < oldsize; i++, ary++) {
5888 PTR_TBL_ENT_t **curentp, **entp, *ent;
5891 curentp = ary + oldsize;
5892 for (entp = ary, ent = *ary; ent; ent = *entp) {
5893 if ((newsize & (UV)ent->oldval) != i) {
5895 ent->next = *curentp;
5910 Perl_sv_dup(pTHX_ SV *sstr)
5917 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
5919 /* look for it in the table first */
5920 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
5924 /* create anew and remember what it is */
5926 ptr_table_store(PL_ptr_table, sstr, dstr);
5929 SvFLAGS(dstr) = SvFLAGS(sstr);
5930 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
5931 SvREFCNT(dstr) = 0; /* must be before any other dups! */
5934 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
5935 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
5936 PL_watch_pvx, SvPVX(sstr));
5939 switch (SvTYPE(sstr)) {
5944 SvANY(dstr) = new_XIV();
5945 SvIVX(dstr) = SvIVX(sstr);
5948 SvANY(dstr) = new_XNV();
5949 SvNVX(dstr) = SvNVX(sstr);
5952 SvANY(dstr) = new_XRV();
5953 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5956 SvANY(dstr) = new_XPV();
5957 SvCUR(dstr) = SvCUR(sstr);
5958 SvLEN(dstr) = SvLEN(sstr);
5960 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5961 else if (SvPVX(sstr) && SvLEN(sstr))
5962 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5964 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5967 SvANY(dstr) = new_XPVIV();
5968 SvCUR(dstr) = SvCUR(sstr);
5969 SvLEN(dstr) = SvLEN(sstr);
5970 SvIVX(dstr) = SvIVX(sstr);
5972 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5973 else if (SvPVX(sstr) && SvLEN(sstr))
5974 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5976 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5979 SvANY(dstr) = new_XPVNV();
5980 SvCUR(dstr) = SvCUR(sstr);
5981 SvLEN(dstr) = SvLEN(sstr);
5982 SvIVX(dstr) = SvIVX(sstr);
5983 SvNVX(dstr) = SvNVX(sstr);
5985 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5986 else if (SvPVX(sstr) && SvLEN(sstr))
5987 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5989 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5992 SvANY(dstr) = new_XPVMG();
5993 SvCUR(dstr) = SvCUR(sstr);
5994 SvLEN(dstr) = SvLEN(sstr);
5995 SvIVX(dstr) = SvIVX(sstr);
5996 SvNVX(dstr) = SvNVX(sstr);
5997 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5998 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6000 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6001 else if (SvPVX(sstr) && SvLEN(sstr))
6002 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6004 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6007 SvANY(dstr) = new_XPVBM();
6008 SvCUR(dstr) = SvCUR(sstr);
6009 SvLEN(dstr) = SvLEN(sstr);
6010 SvIVX(dstr) = SvIVX(sstr);
6011 SvNVX(dstr) = SvNVX(sstr);
6012 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6013 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6015 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6016 else if (SvPVX(sstr) && SvLEN(sstr))
6017 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6019 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6020 BmRARE(dstr) = BmRARE(sstr);
6021 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6022 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6025 SvANY(dstr) = new_XPVLV();
6026 SvCUR(dstr) = SvCUR(sstr);
6027 SvLEN(dstr) = SvLEN(sstr);
6028 SvIVX(dstr) = SvIVX(sstr);
6029 SvNVX(dstr) = SvNVX(sstr);
6030 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6031 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6033 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6034 else if (SvPVX(sstr) && SvLEN(sstr))
6035 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6037 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6038 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6039 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6040 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6041 LvTYPE(dstr) = LvTYPE(sstr);
6044 SvANY(dstr) = new_XPVGV();
6045 SvCUR(dstr) = SvCUR(sstr);
6046 SvLEN(dstr) = SvLEN(sstr);
6047 SvIVX(dstr) = SvIVX(sstr);
6048 SvNVX(dstr) = SvNVX(sstr);
6049 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6050 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6052 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6053 else if (SvPVX(sstr) && SvLEN(sstr))
6054 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6056 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6057 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6058 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6059 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6060 GvFLAGS(dstr) = GvFLAGS(sstr);
6061 GvGP(dstr) = gp_dup(GvGP(sstr));
6062 (void)GpREFCNT_inc(GvGP(dstr));
6065 SvANY(dstr) = new_XPVIO();
6066 SvCUR(dstr) = SvCUR(sstr);
6067 SvLEN(dstr) = SvLEN(sstr);
6068 SvIVX(dstr) = SvIVX(sstr);
6069 SvNVX(dstr) = SvNVX(sstr);
6070 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6071 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6073 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6074 else if (SvPVX(sstr) && SvLEN(sstr))
6075 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6077 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6078 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6079 if (IoOFP(sstr) == IoIFP(sstr))
6080 IoOFP(dstr) = IoIFP(dstr);
6082 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6083 /* PL_rsfp_filters entries have fake IoDIRP() */
6084 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6085 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6087 IoDIRP(dstr) = IoDIRP(sstr);
6088 IoLINES(dstr) = IoLINES(sstr);
6089 IoPAGE(dstr) = IoPAGE(sstr);
6090 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6091 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6092 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6093 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6094 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6095 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6096 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6097 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6098 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6099 IoTYPE(dstr) = IoTYPE(sstr);
6100 IoFLAGS(dstr) = IoFLAGS(sstr);
6103 SvANY(dstr) = new_XPVAV();
6104 SvCUR(dstr) = SvCUR(sstr);
6105 SvLEN(dstr) = SvLEN(sstr);
6106 SvIVX(dstr) = SvIVX(sstr);
6107 SvNVX(dstr) = SvNVX(sstr);
6108 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6109 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6110 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6111 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6112 if (AvARRAY((AV*)sstr)) {
6113 SV **dst_ary, **src_ary;
6114 SSize_t items = AvFILLp((AV*)sstr) + 1;
6116 src_ary = AvARRAY((AV*)sstr);
6117 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6118 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6119 SvPVX(dstr) = (char*)dst_ary;
6120 AvALLOC((AV*)dstr) = dst_ary;
6121 if (AvREAL((AV*)sstr)) {
6123 *dst_ary++ = sv_dup_inc(*src_ary++);
6127 *dst_ary++ = sv_dup(*src_ary++);
6129 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6130 while (items-- > 0) {
6131 *dst_ary++ = &PL_sv_undef;
6135 SvPVX(dstr) = Nullch;
6136 AvALLOC((AV*)dstr) = (SV**)NULL;
6140 SvANY(dstr) = new_XPVHV();
6141 SvCUR(dstr) = SvCUR(sstr);
6142 SvLEN(dstr) = SvLEN(sstr);
6143 SvIVX(dstr) = SvIVX(sstr);
6144 SvNVX(dstr) = SvNVX(sstr);
6145 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6146 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6147 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6148 if (HvARRAY((HV*)sstr)) {
6151 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6152 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6153 Newz(0, dxhv->xhv_array,
6154 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6155 while (i <= sxhv->xhv_max) {
6156 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6157 !!HvSHAREKEYS(sstr));
6160 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6163 SvPVX(dstr) = Nullch;
6164 HvEITER((HV*)dstr) = (HE*)NULL;
6166 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6167 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6170 SvANY(dstr) = new_XPVFM();
6171 FmLINES(dstr) = FmLINES(sstr);
6175 SvANY(dstr) = new_XPVCV();
6177 SvCUR(dstr) = SvCUR(sstr);
6178 SvLEN(dstr) = SvLEN(sstr);
6179 SvIVX(dstr) = SvIVX(sstr);
6180 SvNVX(dstr) = SvNVX(sstr);
6181 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6182 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6183 if (SvPVX(sstr) && SvLEN(sstr))
6184 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6186 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6187 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6188 CvSTART(dstr) = CvSTART(sstr);
6189 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6190 CvXSUB(dstr) = CvXSUB(sstr);
6191 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6192 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6193 CvDEPTH(dstr) = CvDEPTH(sstr);
6194 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6195 /* XXX padlists are real, but pretend to be not */
6196 AvREAL_on(CvPADLIST(sstr));
6197 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6198 AvREAL_off(CvPADLIST(sstr));
6199 AvREAL_off(CvPADLIST(dstr));
6202 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6203 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6204 CvFLAGS(dstr) = CvFLAGS(sstr);
6207 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6211 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6218 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6223 return (PERL_CONTEXT*)NULL;
6225 /* look for it in the table first */
6226 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6230 /* create anew and remember what it is */
6231 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6232 ptr_table_store(PL_ptr_table, cxs, ncxs);
6235 PERL_CONTEXT *cx = &cxs[ix];
6236 PERL_CONTEXT *ncx = &ncxs[ix];
6237 ncx->cx_type = cx->cx_type;
6238 if (CxTYPE(cx) == CXt_SUBST) {
6239 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6242 ncx->blk_oldsp = cx->blk_oldsp;
6243 ncx->blk_oldcop = cx->blk_oldcop;
6244 ncx->blk_oldretsp = cx->blk_oldretsp;
6245 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6246 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6247 ncx->blk_oldpm = cx->blk_oldpm;
6248 ncx->blk_gimme = cx->blk_gimme;
6249 switch (CxTYPE(cx)) {
6251 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6252 ? cv_dup_inc(cx->blk_sub.cv)
6253 : cv_dup(cx->blk_sub.cv));
6254 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6255 ? av_dup_inc(cx->blk_sub.argarray)
6257 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6258 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6259 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6260 ncx->blk_sub.lval = cx->blk_sub.lval;
6263 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6264 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6265 ncx->blk_eval.old_name = SAVEPV(cx->blk_eval.old_name);
6266 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6267 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
6270 ncx->blk_loop.label = cx->blk_loop.label;
6271 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
6272 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
6273 ncx->blk_loop.next_op = cx->blk_loop.next_op;
6274 ncx->blk_loop.last_op = cx->blk_loop.last_op;
6275 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
6276 ? cx->blk_loop.iterdata
6277 : gv_dup((GV*)cx->blk_loop.iterdata));
6278 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
6279 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
6280 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
6281 ncx->blk_loop.iterix = cx->blk_loop.iterix;
6282 ncx->blk_loop.itermax = cx->blk_loop.itermax;
6285 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
6286 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
6287 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
6288 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6301 Perl_si_dup(pTHX_ PERL_SI *si)
6306 return (PERL_SI*)NULL;
6308 /* look for it in the table first */
6309 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6313 /* create anew and remember what it is */
6314 Newz(56, nsi, 1, PERL_SI);
6315 ptr_table_store(PL_ptr_table, si, nsi);
6317 nsi->si_stack = av_dup_inc(si->si_stack);
6318 nsi->si_cxix = si->si_cxix;
6319 nsi->si_cxmax = si->si_cxmax;
6320 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6321 nsi->si_type = si->si_type;
6322 nsi->si_prev = si_dup(si->si_prev);
6323 nsi->si_next = si_dup(si->si_next);
6324 nsi->si_markoff = si->si_markoff;
6329 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
6330 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
6331 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
6332 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
6333 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
6334 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
6335 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
6336 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
6337 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
6338 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
6339 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
6340 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
6343 #define pv_dup_inc(p) SAVEPV(p)
6344 #define pv_dup(p) SAVEPV(p)
6345 #define svp_dup_inc(p,pp) any_dup(p,pp)
6348 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
6355 /* look for it in the table first */
6356 ret = ptr_table_fetch(PL_ptr_table, v);
6360 /* see if it is part of the interpreter structure */
6361 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
6362 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
6370 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
6372 ANY *ss = proto_perl->Tsavestack;
6373 I32 ix = proto_perl->Tsavestack_ix;
6374 I32 max = proto_perl->Tsavestack_max;
6387 void (*dptr) (void*);
6388 void (*dxptr) (pTHXo_ void*);
6390 Newz(54, nss, max, ANY);
6396 case SAVEt_ITEM: /* normal string */
6397 sv = (SV*)POPPTR(ss,ix);
6398 TOPPTR(nss,ix) = sv_dup_inc(sv);
6399 sv = (SV*)POPPTR(ss,ix);
6400 TOPPTR(nss,ix) = sv_dup_inc(sv);
6402 case SAVEt_SV: /* scalar reference */
6403 sv = (SV*)POPPTR(ss,ix);
6404 TOPPTR(nss,ix) = sv_dup_inc(sv);
6405 gv = (GV*)POPPTR(ss,ix);
6406 TOPPTR(nss,ix) = gv_dup_inc(gv);
6408 case SAVEt_GENERIC_SVREF: /* generic sv */
6409 case SAVEt_SVREF: /* scalar reference */
6410 sv = (SV*)POPPTR(ss,ix);
6411 TOPPTR(nss,ix) = sv_dup_inc(sv);
6412 ptr = POPPTR(ss,ix);
6413 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
6415 case SAVEt_AV: /* array reference */
6416 av = (AV*)POPPTR(ss,ix);
6417 TOPPTR(nss,ix) = av_dup_inc(av);
6418 gv = (GV*)POPPTR(ss,ix);
6419 TOPPTR(nss,ix) = gv_dup(gv);
6421 case SAVEt_HV: /* hash reference */
6422 hv = (HV*)POPPTR(ss,ix);
6423 TOPPTR(nss,ix) = hv_dup_inc(hv);
6424 gv = (GV*)POPPTR(ss,ix);
6425 TOPPTR(nss,ix) = gv_dup(gv);
6427 case SAVEt_INT: /* int reference */
6428 ptr = POPPTR(ss,ix);
6429 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6430 intval = (int)POPINT(ss,ix);
6431 TOPINT(nss,ix) = intval;
6433 case SAVEt_LONG: /* long reference */
6434 ptr = POPPTR(ss,ix);
6435 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6436 longval = (long)POPLONG(ss,ix);
6437 TOPLONG(nss,ix) = longval;
6439 case SAVEt_I32: /* I32 reference */
6440 case SAVEt_I16: /* I16 reference */
6441 case SAVEt_I8: /* I8 reference */
6442 ptr = POPPTR(ss,ix);
6443 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6447 case SAVEt_IV: /* IV reference */
6448 ptr = POPPTR(ss,ix);
6449 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6453 case SAVEt_SPTR: /* SV* reference */
6454 ptr = POPPTR(ss,ix);
6455 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6456 sv = (SV*)POPPTR(ss,ix);
6457 TOPPTR(nss,ix) = sv_dup(sv);
6459 case SAVEt_VPTR: /* random* reference */
6460 ptr = POPPTR(ss,ix);
6461 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6462 ptr = POPPTR(ss,ix);
6463 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6465 case SAVEt_PPTR: /* char* reference */
6466 ptr = POPPTR(ss,ix);
6467 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6468 c = (char*)POPPTR(ss,ix);
6469 TOPPTR(nss,ix) = pv_dup(c);
6471 case SAVEt_HPTR: /* HV* reference */
6472 ptr = POPPTR(ss,ix);
6473 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6474 hv = (HV*)POPPTR(ss,ix);
6475 TOPPTR(nss,ix) = hv_dup(hv);
6477 case SAVEt_APTR: /* AV* reference */
6478 ptr = POPPTR(ss,ix);
6479 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6480 av = (AV*)POPPTR(ss,ix);
6481 TOPPTR(nss,ix) = av_dup(av);
6484 gv = (GV*)POPPTR(ss,ix);
6485 TOPPTR(nss,ix) = gv_dup(gv);
6487 case SAVEt_GP: /* scalar reference */
6488 gp = (GP*)POPPTR(ss,ix);
6489 TOPPTR(nss,ix) = gp = gp_dup(gp);
6490 (void)GpREFCNT_inc(gp);
6491 gv = (GV*)POPPTR(ss,ix);
6492 TOPPTR(nss,ix) = gv_dup_inc(c);
6493 c = (char*)POPPTR(ss,ix);
6494 TOPPTR(nss,ix) = pv_dup(c);
6501 sv = (SV*)POPPTR(ss,ix);
6502 TOPPTR(nss,ix) = sv_dup_inc(sv);
6505 ptr = POPPTR(ss,ix);
6506 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
6507 /* these are assumed to be refcounted properly */
6508 switch (((OP*)ptr)->op_type) {
6515 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6518 TOPPTR(nss,ix) = Nullop;
6523 TOPPTR(nss,ix) = Nullop;
6526 c = (char*)POPPTR(ss,ix);
6527 TOPPTR(nss,ix) = pv_dup_inc(c);
6530 longval = POPLONG(ss,ix);
6531 TOPLONG(nss,ix) = longval;
6534 hv = (HV*)POPPTR(ss,ix);
6535 TOPPTR(nss,ix) = hv_dup_inc(hv);
6536 c = (char*)POPPTR(ss,ix);
6537 TOPPTR(nss,ix) = pv_dup_inc(c);
6541 case SAVEt_DESTRUCTOR:
6542 ptr = POPPTR(ss,ix);
6543 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
6544 dptr = POPDPTR(ss,ix);
6545 TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
6547 case SAVEt_DESTRUCTOR_X:
6548 ptr = POPPTR(ss,ix);
6549 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
6550 dxptr = POPDXPTR(ss,ix);
6551 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
6553 case SAVEt_REGCONTEXT:
6559 case SAVEt_STACK_POS: /* Position on Perl stack */
6563 case SAVEt_AELEM: /* array element */
6564 sv = (SV*)POPPTR(ss,ix);
6565 TOPPTR(nss,ix) = sv_dup_inc(sv);
6568 av = (AV*)POPPTR(ss,ix);
6569 TOPPTR(nss,ix) = av_dup_inc(av);
6571 case SAVEt_HELEM: /* hash element */
6572 sv = (SV*)POPPTR(ss,ix);
6573 TOPPTR(nss,ix) = sv_dup_inc(sv);
6574 sv = (SV*)POPPTR(ss,ix);
6575 TOPPTR(nss,ix) = sv_dup_inc(sv);
6576 hv = (HV*)POPPTR(ss,ix);
6577 TOPPTR(nss,ix) = hv_dup_inc(hv);
6580 ptr = POPPTR(ss,ix);
6581 TOPPTR(nss,ix) = ptr;
6588 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
6600 perl_clone(PerlInterpreter *proto_perl, UV flags)
6603 CPerlObj *pPerl = (CPerlObj*)proto_perl;
6606 #ifdef PERL_IMPLICIT_SYS
6607 return perl_clone_using(proto_perl, flags,
6609 proto_perl->IMemShared,
6610 proto_perl->IMemParse,
6620 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
6621 struct IPerlMem* ipM, struct IPerlMem* ipMS,
6622 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
6623 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6624 struct IPerlDir* ipD, struct IPerlSock* ipS,
6625 struct IPerlProc* ipP)
6627 /* XXX many of the string copies here can be optimized if they're
6628 * constants; they need to be allocated as common memory and just
6629 * their pointers copied. */
6635 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
6637 PERL_SET_INTERP(pPerl);
6638 # else /* !PERL_OBJECT */
6639 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6640 PERL_SET_INTERP(my_perl);
6643 memset(my_perl, 0xab, sizeof(PerlInterpreter));
6648 # else /* !DEBUGGING */
6649 Zero(my_perl, 1, PerlInterpreter);
6650 # endif /* DEBUGGING */
6654 PL_MemShared = ipMS;
6662 # endif /* PERL_OBJECT */
6663 #else /* !PERL_IMPLICIT_SYS */
6667 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
6668 PERL_SET_INTERP(my_perl);
6671 memset(my_perl, 0xab, sizeof(PerlInterpreter));
6676 # else /* !DEBUGGING */
6677 Zero(my_perl, 1, PerlInterpreter);
6678 # endif /* DEBUGGING */
6679 #endif /* PERL_IMPLICIT_SYS */
6682 PL_xiv_arenaroot = NULL;
6687 PL_xpviv_root = NULL;
6688 PL_xpvnv_root = NULL;
6689 PL_xpvcv_root = NULL;
6690 PL_xpvav_root = NULL;
6691 PL_xpvhv_root = NULL;
6692 PL_xpvmg_root = NULL;
6693 PL_xpvlv_root = NULL;
6694 PL_xpvbm_root = NULL;
6696 PL_nice_chunk = NULL;
6697 PL_nice_chunk_size = 0;
6700 PL_sv_root = Nullsv;
6701 PL_sv_arenaroot = Nullsv;
6703 PL_debug = proto_perl->Idebug;
6705 /* create SV map for pointer relocation */
6706 PL_ptr_table = ptr_table_new();
6708 /* initialize these special pointers as early as possible */
6709 SvANY(&PL_sv_undef) = NULL;
6710 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
6711 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
6712 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
6715 SvUPGRADE(&PL_sv_no, SVt_PVNV);
6717 SvANY(&PL_sv_no) = new_XPVNV();
6719 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
6720 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6721 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
6722 SvCUR(&PL_sv_no) = 0;
6723 SvLEN(&PL_sv_no) = 1;
6724 SvNVX(&PL_sv_no) = 0;
6725 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
6728 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
6730 SvANY(&PL_sv_yes) = new_XPVNV();
6732 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6733 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6734 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
6735 SvCUR(&PL_sv_yes) = 1;
6736 SvLEN(&PL_sv_yes) = 2;
6737 SvNVX(&PL_sv_yes) = 1;
6738 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
6740 /* create shared string table */
6741 PL_strtab = newHV();
6742 HvSHAREKEYS_off(PL_strtab);
6743 hv_ksplit(PL_strtab, 512);
6744 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
6746 PL_compiling = proto_perl->Icompiling;
6747 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
6748 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
6749 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
6750 if (!specialWARN(PL_compiling.cop_warnings))
6751 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
6752 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
6754 /* pseudo environmental stuff */
6755 PL_origargc = proto_perl->Iorigargc;
6757 New(0, PL_origargv, i+1, char*);
6758 PL_origargv[i] = '\0';
6760 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
6762 PL_envgv = gv_dup(proto_perl->Ienvgv);
6763 PL_incgv = gv_dup(proto_perl->Iincgv);
6764 PL_hintgv = gv_dup(proto_perl->Ihintgv);
6765 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
6766 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
6767 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
6770 PL_minus_c = proto_perl->Iminus_c;
6771 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
6772 PL_localpatches = proto_perl->Ilocalpatches;
6773 PL_splitstr = proto_perl->Isplitstr;
6774 PL_preprocess = proto_perl->Ipreprocess;
6775 PL_minus_n = proto_perl->Iminus_n;
6776 PL_minus_p = proto_perl->Iminus_p;
6777 PL_minus_l = proto_perl->Iminus_l;
6778 PL_minus_a = proto_perl->Iminus_a;
6779 PL_minus_F = proto_perl->Iminus_F;
6780 PL_doswitches = proto_perl->Idoswitches;
6781 PL_dowarn = proto_perl->Idowarn;
6782 PL_doextract = proto_perl->Idoextract;
6783 PL_sawampersand = proto_perl->Isawampersand;
6784 PL_unsafe = proto_perl->Iunsafe;
6785 PL_inplace = SAVEPV(proto_perl->Iinplace);
6786 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
6787 PL_perldb = proto_perl->Iperldb;
6788 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6790 /* magical thingies */
6791 /* XXX time(&PL_basetime) when asked for? */
6792 PL_basetime = proto_perl->Ibasetime;
6793 PL_formfeed = sv_dup(proto_perl->Iformfeed);
6795 PL_maxsysfd = proto_perl->Imaxsysfd;
6796 PL_multiline = proto_perl->Imultiline;
6797 PL_statusvalue = proto_perl->Istatusvalue;
6799 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
6802 /* shortcuts to various I/O objects */
6803 PL_stdingv = gv_dup(proto_perl->Istdingv);
6804 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
6805 PL_defgv = gv_dup(proto_perl->Idefgv);
6806 PL_argvgv = gv_dup(proto_perl->Iargvgv);
6807 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
6808 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
6810 /* shortcuts to regexp stuff */
6811 PL_replgv = gv_dup(proto_perl->Ireplgv);
6813 /* shortcuts to misc objects */
6814 PL_errgv = gv_dup(proto_perl->Ierrgv);
6816 /* shortcuts to debugging objects */
6817 PL_DBgv = gv_dup(proto_perl->IDBgv);
6818 PL_DBline = gv_dup(proto_perl->IDBline);
6819 PL_DBsub = gv_dup(proto_perl->IDBsub);
6820 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
6821 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
6822 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
6823 PL_lineary = av_dup(proto_perl->Ilineary);
6824 PL_dbargs = av_dup(proto_perl->Idbargs);
6827 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
6828 PL_curstash = hv_dup(proto_perl->Tcurstash);
6829 PL_debstash = hv_dup(proto_perl->Idebstash);
6830 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
6831 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
6833 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
6834 PL_endav = av_dup_inc(proto_perl->Iendav);
6835 PL_stopav = av_dup_inc(proto_perl->Istopav);
6836 PL_initav = av_dup_inc(proto_perl->Iinitav);
6838 PL_sub_generation = proto_perl->Isub_generation;
6840 /* funky return mechanisms */
6841 PL_forkprocess = proto_perl->Iforkprocess;
6843 /* subprocess state */
6844 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
6846 /* internal state */
6847 PL_tainting = proto_perl->Itainting;
6848 PL_maxo = proto_perl->Imaxo;
6849 if (proto_perl->Iop_mask)
6850 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6852 PL_op_mask = Nullch;
6854 /* current interpreter roots */
6855 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
6856 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
6857 PL_main_start = proto_perl->Imain_start;
6858 PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root);
6859 PL_eval_start = proto_perl->Ieval_start;
6861 /* runtime control stuff */
6862 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
6863 PL_copline = proto_perl->Icopline;
6865 PL_filemode = proto_perl->Ifilemode;
6866 PL_lastfd = proto_perl->Ilastfd;
6867 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
6870 PL_gensym = proto_perl->Igensym;
6871 PL_preambled = proto_perl->Ipreambled;
6872 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
6873 PL_laststatval = proto_perl->Ilaststatval;
6874 PL_laststype = proto_perl->Ilaststype;
6875 PL_mess_sv = Nullsv;
6877 PL_orslen = proto_perl->Iorslen;
6878 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
6879 PL_ofmt = SAVEPV(proto_perl->Iofmt);
6881 /* interpreter atexit processing */
6882 PL_exitlistlen = proto_perl->Iexitlistlen;
6883 if (PL_exitlistlen) {
6884 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6885 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6888 PL_exitlist = (PerlExitListEntry*)NULL;
6889 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
6891 PL_profiledata = NULL;
6892 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
6893 /* PL_rsfp_filters entries have fake IoDIRP() */
6894 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
6896 PL_compcv = cv_dup(proto_perl->Icompcv);
6897 PL_comppad = av_dup(proto_perl->Icomppad);
6898 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
6899 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
6900 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
6901 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
6902 proto_perl->Tcurpad);
6904 #ifdef HAVE_INTERP_INTERN
6905 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6908 /* more statics moved here */
6909 PL_generation = proto_perl->Igeneration;
6910 PL_DBcv = cv_dup(proto_perl->IDBcv);
6912 PL_in_clean_objs = proto_perl->Iin_clean_objs;
6913 PL_in_clean_all = proto_perl->Iin_clean_all;
6915 PL_uid = proto_perl->Iuid;
6916 PL_euid = proto_perl->Ieuid;
6917 PL_gid = proto_perl->Igid;
6918 PL_egid = proto_perl->Iegid;
6919 PL_nomemok = proto_perl->Inomemok;
6920 PL_an = proto_perl->Ian;
6921 PL_cop_seqmax = proto_perl->Icop_seqmax;
6922 PL_op_seqmax = proto_perl->Iop_seqmax;
6923 PL_evalseq = proto_perl->Ievalseq;
6924 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
6925 PL_origalen = proto_perl->Iorigalen;
6926 PL_pidstatus = newHV(); /* XXX flag for cloning? */
6927 PL_osname = SAVEPV(proto_perl->Iosname);
6928 PL_sh_path = SAVEPV(proto_perl->Ish_path);
6929 PL_sighandlerp = proto_perl->Isighandlerp;
6932 PL_runops = proto_perl->Irunops;
6934 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
6937 PL_cshlen = proto_perl->Icshlen;
6938 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6941 PL_lex_state = proto_perl->Ilex_state;
6942 PL_lex_defer = proto_perl->Ilex_defer;
6943 PL_lex_expect = proto_perl->Ilex_expect;
6944 PL_lex_formbrack = proto_perl->Ilex_formbrack;
6945 PL_lex_dojoin = proto_perl->Ilex_dojoin;
6946 PL_lex_starts = proto_perl->Ilex_starts;
6947 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
6948 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
6949 PL_lex_op = proto_perl->Ilex_op;
6950 PL_lex_inpat = proto_perl->Ilex_inpat;
6951 PL_lex_inwhat = proto_perl->Ilex_inwhat;
6952 PL_lex_brackets = proto_perl->Ilex_brackets;
6953 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6954 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
6955 PL_lex_casemods = proto_perl->Ilex_casemods;
6956 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6957 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
6959 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6960 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6961 PL_nexttoke = proto_perl->Inexttoke;
6963 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
6964 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6965 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6966 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6967 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6968 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6969 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6970 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6971 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6972 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6973 PL_pending_ident = proto_perl->Ipending_ident;
6974 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
6976 PL_expect = proto_perl->Iexpect;
6978 PL_multi_start = proto_perl->Imulti_start;
6979 PL_multi_end = proto_perl->Imulti_end;
6980 PL_multi_open = proto_perl->Imulti_open;
6981 PL_multi_close = proto_perl->Imulti_close;
6983 PL_error_count = proto_perl->Ierror_count;
6984 PL_subline = proto_perl->Isubline;
6985 PL_subname = sv_dup_inc(proto_perl->Isubname);
6987 PL_min_intro_pending = proto_perl->Imin_intro_pending;
6988 PL_max_intro_pending = proto_perl->Imax_intro_pending;
6989 PL_padix = proto_perl->Ipadix;
6990 PL_padix_floor = proto_perl->Ipadix_floor;
6991 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
6993 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6994 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6995 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
6996 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6997 PL_last_lop_op = proto_perl->Ilast_lop_op;
6998 PL_in_my = proto_perl->Iin_my;
6999 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7001 PL_cryptseen = proto_perl->Icryptseen;
7004 PL_hints = proto_perl->Ihints;
7006 PL_amagic_generation = proto_perl->Iamagic_generation;
7008 #ifdef USE_LOCALE_COLLATE
7009 PL_collation_ix = proto_perl->Icollation_ix;
7010 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7011 PL_collation_standard = proto_perl->Icollation_standard;
7012 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7013 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7014 #endif /* USE_LOCALE_COLLATE */
7016 #ifdef USE_LOCALE_NUMERIC
7017 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7018 PL_numeric_standard = proto_perl->Inumeric_standard;
7019 PL_numeric_local = proto_perl->Inumeric_local;
7020 PL_numeric_radix = proto_perl->Inumeric_radix;
7021 #endif /* !USE_LOCALE_NUMERIC */
7023 /* utf8 character classes */
7024 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7025 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7026 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7027 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7028 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7029 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7030 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7031 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7032 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7033 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7034 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7035 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7036 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7037 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7038 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7039 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7040 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7043 PL_last_swash_hv = Nullhv; /* reinits on demand */
7044 PL_last_swash_klen = 0;
7045 PL_last_swash_key[0]= '\0';
7046 PL_last_swash_tmps = (U8*)NULL;
7047 PL_last_swash_slen = 0;
7049 /* perly.c globals */
7050 PL_yydebug = proto_perl->Iyydebug;
7051 PL_yynerrs = proto_perl->Iyynerrs;
7052 PL_yyerrflag = proto_perl->Iyyerrflag;
7053 PL_yychar = proto_perl->Iyychar;
7054 PL_yyval = proto_perl->Iyyval;
7055 PL_yylval = proto_perl->Iyylval;
7057 PL_glob_index = proto_perl->Iglob_index;
7058 PL_srand_called = proto_perl->Isrand_called;
7059 PL_uudmap['M'] = 0; /* reinits on demand */
7060 PL_bitcount = Nullch; /* reinits on demand */
7062 if (proto_perl->Ipsig_ptr) {
7063 int sig_num[] = { SIG_NUM };
7064 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7065 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7066 for (i = 1; PL_sig_name[i]; i++) {
7067 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7068 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7072 PL_psig_ptr = (SV**)NULL;
7073 PL_psig_name = (SV**)NULL;
7076 /* thrdvar.h stuff */
7079 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7080 PL_tmps_ix = proto_perl->Ttmps_ix;
7081 PL_tmps_max = proto_perl->Ttmps_max;
7082 PL_tmps_floor = proto_perl->Ttmps_floor;
7083 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7085 while (i <= PL_tmps_ix) {
7086 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7090 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7091 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7092 Newz(54, PL_markstack, i, I32);
7093 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7094 - proto_perl->Tmarkstack);
7095 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7096 - proto_perl->Tmarkstack);
7097 Copy(proto_perl->Tmarkstack, PL_markstack,
7098 PL_markstack_ptr - PL_markstack + 1, I32);
7100 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7101 * NOTE: unlike the others! */
7102 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7103 PL_scopestack_max = proto_perl->Tscopestack_max;
7104 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7105 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7107 /* next push_return() sets PL_retstack[PL_retstack_ix]
7108 * NOTE: unlike the others! */
7109 PL_retstack_ix = proto_perl->Tretstack_ix;
7110 PL_retstack_max = proto_perl->Tretstack_max;
7111 Newz(54, PL_retstack, PL_retstack_max, OP*);
7112 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7114 /* NOTE: si_dup() looks at PL_markstack */
7115 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7117 /* PL_curstack = PL_curstackinfo->si_stack; */
7118 PL_curstack = av_dup(proto_perl->Tcurstack);
7119 PL_mainstack = av_dup(proto_perl->Tmainstack);
7121 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7122 PL_stack_base = AvARRAY(PL_curstack);
7123 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7124 - proto_perl->Tstack_base);
7125 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7127 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7128 * NOTE: unlike the others! */
7129 PL_savestack_ix = proto_perl->Tsavestack_ix;
7130 PL_savestack_max = proto_perl->Tsavestack_max;
7131 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7132 PL_savestack = ss_dup(proto_perl);
7138 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7139 PL_top_env = &PL_start_env;
7141 PL_op = proto_perl->Top;
7144 PL_Xpv = (XPV*)NULL;
7145 PL_na = proto_perl->Tna;
7147 PL_statbuf = proto_perl->Tstatbuf;
7148 PL_statcache = proto_perl->Tstatcache;
7149 PL_statgv = gv_dup(proto_perl->Tstatgv);
7150 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7152 PL_timesbuf = proto_perl->Ttimesbuf;
7155 PL_tainted = proto_perl->Ttainted;
7156 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7157 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7158 PL_rs = sv_dup_inc(proto_perl->Trs);
7159 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7160 PL_ofslen = proto_perl->Tofslen;
7161 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7162 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7163 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7164 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7165 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7166 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7168 PL_restartop = proto_perl->Trestartop;
7169 PL_in_eval = proto_perl->Tin_eval;
7170 PL_delaymagic = proto_perl->Tdelaymagic;
7171 PL_dirty = proto_perl->Tdirty;
7172 PL_localizing = proto_perl->Tlocalizing;
7174 PL_protect = proto_perl->Tprotect;
7175 PL_errors = sv_dup_inc(proto_perl->Terrors);
7176 PL_av_fetch_sv = Nullsv;
7177 PL_hv_fetch_sv = Nullsv;
7178 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7179 PL_modcount = proto_perl->Tmodcount;
7180 PL_lastgotoprobe = Nullop;
7181 PL_dumpindent = proto_perl->Tdumpindent;
7183 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7184 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7185 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7186 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7187 PL_sortcxix = proto_perl->Tsortcxix;
7188 PL_efloatbuf = Nullch; /* reinits on demand */
7189 PL_efloatsize = 0; /* reinits on demand */
7193 PL_screamfirst = NULL;
7194 PL_screamnext = NULL;
7195 PL_maxscream = -1; /* reinits on demand */
7196 PL_lastscream = Nullsv;
7198 PL_watchaddr = NULL;
7199 PL_watchok = Nullch;
7201 PL_regdummy = proto_perl->Tregdummy;
7202 PL_regcomp_parse = Nullch;
7203 PL_regxend = Nullch;
7204 PL_regcode = (regnode*)NULL;
7207 PL_regprecomp = Nullch;
7212 PL_seen_zerolen = 0;
7214 PL_regcomp_rx = (regexp*)NULL;
7216 PL_colorset = 0; /* reinits PL_colors[] */
7217 /*PL_colors[6] = {0,0,0,0,0,0};*/
7218 PL_reg_whilem_seen = 0;
7219 PL_reginput = Nullch;
7222 PL_regstartp = (I32*)NULL;
7223 PL_regendp = (I32*)NULL;
7224 PL_reglastparen = (U32*)NULL;
7225 PL_regtill = Nullch;
7227 PL_reg_start_tmp = (char**)NULL;
7228 PL_reg_start_tmpl = 0;
7229 PL_regdata = (struct reg_data*)NULL;
7232 PL_reg_eval_set = 0;
7234 PL_regprogram = (regnode*)NULL;
7236 PL_regcc = (CURCUR*)NULL;
7237 PL_reg_call_cc = (struct re_cc_state*)NULL;
7238 PL_reg_re = (regexp*)NULL;
7239 PL_reg_ganch = Nullch;
7241 PL_reg_magic = (MAGIC*)NULL;
7243 PL_reg_oldcurpm = (PMOP*)NULL;
7244 PL_reg_curpm = (PMOP*)NULL;
7245 PL_reg_oldsaved = Nullch;
7246 PL_reg_oldsavedlen = 0;
7248 PL_reg_leftiter = 0;
7249 PL_reg_poscache = Nullch;
7250 PL_reg_poscache_size= 0;
7252 /* RE engine - function pointers */
7253 PL_regcompp = proto_perl->Tregcompp;
7254 PL_regexecp = proto_perl->Tregexecp;
7255 PL_regint_start = proto_perl->Tregint_start;
7256 PL_regint_string = proto_perl->Tregint_string;
7257 PL_regfree = proto_perl->Tregfree;
7259 PL_reginterp_cnt = 0;
7260 PL_reg_starttry = 0;
7263 return (PerlInterpreter*)pPerl;
7269 #else /* !USE_ITHREADS */
7275 #endif /* USE_ITHREADS */
7278 do_report_used(pTHXo_ SV *sv)
7280 if (SvTYPE(sv) != SVTYPEMASK) {
7281 PerlIO_printf(Perl_debug_log, "****\n");
7287 do_clean_objs(pTHXo_ SV *sv)
7291 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7292 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7298 /* XXX Might want to check arrays, etc. */
7301 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7303 do_clean_named_objs(pTHXo_ SV *sv)
7305 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
7306 if ( SvOBJECT(GvSV(sv)) ||
7307 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7308 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7309 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7310 GvCV(sv) && SvOBJECT(GvCV(sv)) )
7312 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
7320 do_clean_all(pTHXo_ SV *sv)
7322 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
7323 SvFLAGS(sv) |= SVf_BREAK;