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);
2261 /* This function is only called on magical items */
2263 Perl_sv_2bool(pTHX_ register SV *sv)
2273 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2274 return SvTRUE(tmpsv);
2275 return SvRV(sv) != 0;
2278 register XPV* Xpvtmp;
2279 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2280 (*Xpvtmp->xpv_pv > '0' ||
2281 Xpvtmp->xpv_cur > 1 ||
2282 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2289 return SvIVX(sv) != 0;
2292 return SvNVX(sv) != 0.0;
2299 /* Note: sv_setsv() should not be called with a source string that needs
2300 * to be reused, since it may destroy the source string if it is marked
2305 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2308 register U32 sflags;
2314 SV_CHECK_THINKFIRST(dstr);
2316 sstr = &PL_sv_undef;
2317 stype = SvTYPE(sstr);
2318 dtype = SvTYPE(dstr);
2322 /* There's a lot of redundancy below but we're going for speed here */
2327 if (dtype != SVt_PVGV) {
2328 (void)SvOK_off(dstr);
2336 sv_upgrade(dstr, SVt_IV);
2339 sv_upgrade(dstr, SVt_PVNV);
2343 sv_upgrade(dstr, SVt_PVIV);
2346 (void)SvIOK_only(dstr);
2347 SvIVX(dstr) = SvIVX(sstr);
2360 sv_upgrade(dstr, SVt_NV);
2365 sv_upgrade(dstr, SVt_PVNV);
2368 SvNVX(dstr) = SvNVX(sstr);
2369 (void)SvNOK_only(dstr);
2377 sv_upgrade(dstr, SVt_RV);
2378 else if (dtype == SVt_PVGV &&
2379 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2382 if (GvIMPORTED(dstr) != GVf_IMPORTED
2383 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2385 GvIMPORTED_on(dstr);
2396 sv_upgrade(dstr, SVt_PV);
2399 if (dtype < SVt_PVIV)
2400 sv_upgrade(dstr, SVt_PVIV);
2403 if (dtype < SVt_PVNV)
2404 sv_upgrade(dstr, SVt_PVNV);
2411 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2412 PL_op_name[PL_op->op_type]);
2414 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2418 if (dtype <= SVt_PVGV) {
2420 if (dtype != SVt_PVGV) {
2421 char *name = GvNAME(sstr);
2422 STRLEN len = GvNAMELEN(sstr);
2423 sv_upgrade(dstr, SVt_PVGV);
2424 sv_magic(dstr, dstr, '*', name, len);
2425 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2426 GvNAME(dstr) = savepvn(name, len);
2427 GvNAMELEN(dstr) = len;
2428 SvFAKE_on(dstr); /* can coerce to non-glob */
2430 /* ahem, death to those who redefine active sort subs */
2431 else if (PL_curstackinfo->si_type == PERLSI_SORT
2432 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2433 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2435 (void)SvOK_off(dstr);
2436 GvINTRO_off(dstr); /* one-shot flag */
2438 GvGP(dstr) = gp_ref(GvGP(sstr));
2440 if (GvIMPORTED(dstr) != GVf_IMPORTED
2441 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2443 GvIMPORTED_on(dstr);
2451 if (SvGMAGICAL(sstr)) {
2453 if (SvTYPE(sstr) != stype) {
2454 stype = SvTYPE(sstr);
2455 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2459 if (stype == SVt_PVLV)
2460 (void)SvUPGRADE(dstr, SVt_PVNV);
2462 (void)SvUPGRADE(dstr, stype);
2465 sflags = SvFLAGS(sstr);
2467 if (sflags & SVf_ROK) {
2468 if (dtype >= SVt_PV) {
2469 if (dtype == SVt_PVGV) {
2470 SV *sref = SvREFCNT_inc(SvRV(sstr));
2472 int intro = GvINTRO(dstr);
2477 GvINTRO_off(dstr); /* one-shot flag */
2478 Newz(602,gp, 1, GP);
2479 GvGP(dstr) = gp_ref(gp);
2480 GvSV(dstr) = NEWSV(72,0);
2481 GvLINE(dstr) = CopLINE(PL_curcop);
2482 GvEGV(dstr) = (GV*)dstr;
2485 switch (SvTYPE(sref)) {
2488 SAVESPTR(GvAV(dstr));
2490 dref = (SV*)GvAV(dstr);
2491 GvAV(dstr) = (AV*)sref;
2492 if (GvIMPORTED_AV_off(dstr)
2493 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2495 GvIMPORTED_AV_on(dstr);
2500 SAVESPTR(GvHV(dstr));
2502 dref = (SV*)GvHV(dstr);
2503 GvHV(dstr) = (HV*)sref;
2504 if (GvIMPORTED_HV_off(dstr)
2505 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2507 GvIMPORTED_HV_on(dstr);
2512 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2513 SvREFCNT_dec(GvCV(dstr));
2514 GvCV(dstr) = Nullcv;
2515 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2516 PL_sub_generation++;
2518 SAVESPTR(GvCV(dstr));
2521 dref = (SV*)GvCV(dstr);
2522 if (GvCV(dstr) != (CV*)sref) {
2523 CV* cv = GvCV(dstr);
2525 if (!GvCVGEN((GV*)dstr) &&
2526 (CvROOT(cv) || CvXSUB(cv)))
2528 SV *const_sv = cv_const_sv(cv);
2529 bool const_changed = TRUE;
2531 const_changed = sv_cmp(const_sv,
2532 op_const_sv(CvSTART((CV*)sref),
2534 /* ahem, death to those who redefine
2535 * active sort subs */
2536 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2537 PL_sortcop == CvSTART(cv))
2539 "Can't redefine active sort subroutine %s",
2540 GvENAME((GV*)dstr));
2541 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2542 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2543 && HvNAME(GvSTASH(CvGV(cv)))
2544 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2546 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2547 "Constant subroutine %s redefined"
2548 : "Subroutine %s redefined",
2549 GvENAME((GV*)dstr));
2552 cv_ckproto(cv, (GV*)dstr,
2553 SvPOK(sref) ? SvPVX(sref) : Nullch);
2555 GvCV(dstr) = (CV*)sref;
2556 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2557 GvASSUMECV_on(dstr);
2558 PL_sub_generation++;
2560 if (GvIMPORTED_CV_off(dstr)
2561 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2563 GvIMPORTED_CV_on(dstr);
2568 SAVESPTR(GvIOp(dstr));
2570 dref = (SV*)GvIOp(dstr);
2571 GvIOp(dstr) = (IO*)sref;
2575 SAVESPTR(GvSV(dstr));
2577 dref = (SV*)GvSV(dstr);
2579 if (GvIMPORTED_SV_off(dstr)
2580 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2582 GvIMPORTED_SV_on(dstr);
2594 (void)SvOOK_off(dstr); /* backoff */
2596 Safefree(SvPVX(dstr));
2597 SvLEN(dstr)=SvCUR(dstr)=0;
2600 (void)SvOK_off(dstr);
2601 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2603 if (sflags & SVp_NOK) {
2605 SvNVX(dstr) = SvNVX(sstr);
2607 if (sflags & SVp_IOK) {
2608 (void)SvIOK_on(dstr);
2609 SvIVX(dstr) = SvIVX(sstr);
2613 if (SvAMAGIC(sstr)) {
2617 else if (sflags & SVp_POK) {
2620 * Check to see if we can just swipe the string. If so, it's a
2621 * possible small lose on short strings, but a big win on long ones.
2622 * It might even be a win on short strings if SvPVX(dstr)
2623 * has to be allocated and SvPVX(sstr) has to be freed.
2626 if (SvTEMP(sstr) && /* slated for free anyway? */
2627 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2628 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2630 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2632 SvFLAGS(dstr) &= ~SVf_OOK;
2633 Safefree(SvPVX(dstr) - SvIVX(dstr));
2635 else if (SvLEN(dstr))
2636 Safefree(SvPVX(dstr));
2638 (void)SvPOK_only(dstr);
2639 SvPV_set(dstr, SvPVX(sstr));
2640 SvLEN_set(dstr, SvLEN(sstr));
2641 SvCUR_set(dstr, SvCUR(sstr));
2643 (void)SvOK_off(sstr);
2644 SvPV_set(sstr, Nullch);
2649 else { /* have to copy actual string */
2650 STRLEN len = SvCUR(sstr);
2652 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2653 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2654 SvCUR_set(dstr, len);
2655 *SvEND(dstr) = '\0';
2656 (void)SvPOK_only(dstr);
2659 if (sflags & SVp_NOK) {
2661 SvNVX(dstr) = SvNVX(sstr);
2663 if (sflags & SVp_IOK) {
2664 (void)SvIOK_on(dstr);
2665 SvIVX(dstr) = SvIVX(sstr);
2670 else if (sflags & SVp_NOK) {
2671 SvNVX(dstr) = SvNVX(sstr);
2672 (void)SvNOK_only(dstr);
2674 (void)SvIOK_on(dstr);
2675 SvIVX(dstr) = SvIVX(sstr);
2676 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2681 else if (sflags & SVp_IOK) {
2682 (void)SvIOK_only(dstr);
2683 SvIVX(dstr) = SvIVX(sstr);
2688 if (dtype == SVt_PVGV) {
2689 if (ckWARN(WARN_UNSAFE))
2690 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2693 (void)SvOK_off(dstr);
2699 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2701 sv_setsv(dstr,sstr);
2706 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2708 register char *dptr;
2709 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2710 elicit a warning, but it won't hurt. */
2711 SV_CHECK_THINKFIRST(sv);
2716 (void)SvUPGRADE(sv, SVt_PV);
2718 SvGROW(sv, len + 1);
2720 Move(ptr,dptr,len,char);
2723 (void)SvPOK_only(sv); /* validate pointer */
2728 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2730 sv_setpvn(sv,ptr,len);
2735 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2737 register STRLEN len;
2739 SV_CHECK_THINKFIRST(sv);
2745 (void)SvUPGRADE(sv, SVt_PV);
2747 SvGROW(sv, len + 1);
2748 Move(ptr,SvPVX(sv),len+1,char);
2750 (void)SvPOK_only(sv); /* validate pointer */
2755 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2762 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2764 SV_CHECK_THINKFIRST(sv);
2765 (void)SvUPGRADE(sv, SVt_PV);
2770 (void)SvOOK_off(sv);
2771 if (SvPVX(sv) && SvLEN(sv))
2772 Safefree(SvPVX(sv));
2773 Renew(ptr, len+1, char);
2776 SvLEN_set(sv, len+1);
2778 (void)SvPOK_only(sv); /* validate pointer */
2783 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2785 sv_usepvn(sv,ptr,len);
2790 Perl_sv_force_normal(pTHX_ register SV *sv)
2792 if (SvREADONLY(sv)) {
2794 if (PL_curcop != &PL_compiling)
2795 Perl_croak(aTHX_ PL_no_modify);
2799 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2804 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2808 register STRLEN delta;
2810 if (!ptr || !SvPOKp(sv))
2812 SV_CHECK_THINKFIRST(sv);
2813 if (SvTYPE(sv) < SVt_PVIV)
2814 sv_upgrade(sv,SVt_PVIV);
2817 if (!SvLEN(sv)) { /* make copy of shared string */
2818 char *pvx = SvPVX(sv);
2819 STRLEN len = SvCUR(sv);
2820 SvGROW(sv, len + 1);
2821 Move(pvx,SvPVX(sv),len,char);
2825 SvFLAGS(sv) |= SVf_OOK;
2827 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
2828 delta = ptr - SvPVX(sv);
2836 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2841 junk = SvPV_force(sv, tlen);
2842 SvGROW(sv, tlen + len + 1);
2845 Move(ptr,SvPVX(sv)+tlen,len,char);
2848 (void)SvPOK_only(sv); /* validate pointer */
2853 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2855 sv_catpvn(sv,ptr,len);
2860 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
2866 if (s = SvPV(sstr, len))
2867 sv_catpvn(dstr,s,len);
2871 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
2873 sv_catsv(dstr,sstr);
2878 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
2880 register STRLEN len;
2886 junk = SvPV_force(sv, tlen);
2888 SvGROW(sv, tlen + len + 1);
2891 Move(ptr,SvPVX(sv)+tlen,len+1,char);
2893 (void)SvPOK_only(sv); /* validate pointer */
2898 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
2905 Perl_newSV(pTHX_ STRLEN len)
2911 sv_upgrade(sv, SVt_PV);
2912 SvGROW(sv, len + 1);
2917 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
2920 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
2924 if (SvREADONLY(sv)) {
2926 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
2927 Perl_croak(aTHX_ PL_no_modify);
2929 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
2930 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
2937 (void)SvUPGRADE(sv, SVt_PVMG);
2939 Newz(702,mg, 1, MAGIC);
2940 mg->mg_moremagic = SvMAGIC(sv);
2943 if (!obj || obj == sv || how == '#' || how == 'r')
2947 mg->mg_obj = SvREFCNT_inc(obj);
2948 mg->mg_flags |= MGf_REFCOUNTED;
2951 mg->mg_len = namlen;
2954 mg->mg_ptr = savepvn(name, namlen);
2955 else if (namlen == HEf_SVKEY)
2956 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
2960 mg->mg_virtual = &PL_vtbl_sv;
2963 mg->mg_virtual = &PL_vtbl_amagic;
2966 mg->mg_virtual = &PL_vtbl_amagicelem;
2972 mg->mg_virtual = &PL_vtbl_bm;
2975 mg->mg_virtual = &PL_vtbl_regdata;
2978 mg->mg_virtual = &PL_vtbl_regdatum;
2981 mg->mg_virtual = &PL_vtbl_env;
2984 mg->mg_virtual = &PL_vtbl_fm;
2987 mg->mg_virtual = &PL_vtbl_envelem;
2990 mg->mg_virtual = &PL_vtbl_mglob;
2993 mg->mg_virtual = &PL_vtbl_isa;
2996 mg->mg_virtual = &PL_vtbl_isaelem;
2999 mg->mg_virtual = &PL_vtbl_nkeys;
3006 mg->mg_virtual = &PL_vtbl_dbline;
3010 mg->mg_virtual = &PL_vtbl_mutex;
3012 #endif /* USE_THREADS */
3013 #ifdef USE_LOCALE_COLLATE
3015 mg->mg_virtual = &PL_vtbl_collxfrm;
3017 #endif /* USE_LOCALE_COLLATE */
3019 mg->mg_virtual = &PL_vtbl_pack;
3023 mg->mg_virtual = &PL_vtbl_packelem;
3026 mg->mg_virtual = &PL_vtbl_regexp;
3029 mg->mg_virtual = &PL_vtbl_sig;
3032 mg->mg_virtual = &PL_vtbl_sigelem;
3035 mg->mg_virtual = &PL_vtbl_taint;
3039 mg->mg_virtual = &PL_vtbl_uvar;
3042 mg->mg_virtual = &PL_vtbl_vec;
3045 mg->mg_virtual = &PL_vtbl_substr;
3048 mg->mg_virtual = &PL_vtbl_defelem;
3051 mg->mg_virtual = &PL_vtbl_glob;
3054 mg->mg_virtual = &PL_vtbl_arylen;
3057 mg->mg_virtual = &PL_vtbl_pos;
3060 mg->mg_virtual = &PL_vtbl_backref;
3062 case '~': /* Reserved for use by extensions not perl internals. */
3063 /* Useful for attaching extension internal data to perl vars. */
3064 /* Note that multiple extensions may clash if magical scalars */
3065 /* etc holding private data from one are passed to another. */
3069 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3073 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3077 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3081 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3084 for (mg = *mgp; mg; mg = *mgp) {
3085 if (mg->mg_type == type) {
3086 MGVTBL* vtbl = mg->mg_virtual;
3087 *mgp = mg->mg_moremagic;
3088 if (vtbl && vtbl->svt_free)
3089 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3090 if (mg->mg_ptr && mg->mg_type != 'g')
3091 if (mg->mg_len >= 0)
3092 Safefree(mg->mg_ptr);
3093 else if (mg->mg_len == HEf_SVKEY)
3094 SvREFCNT_dec((SV*)mg->mg_ptr);
3095 if (mg->mg_flags & MGf_REFCOUNTED)
3096 SvREFCNT_dec(mg->mg_obj);
3100 mgp = &mg->mg_moremagic;
3104 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3111 Perl_sv_rvweaken(pTHX_ SV *sv)
3114 if (!SvOK(sv)) /* let undefs pass */
3117 Perl_croak(aTHX_ "Can't weaken a nonreference");
3118 else if (SvWEAKREF(sv)) {
3120 if (ckWARN(WARN_MISC))
3121 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3125 sv_add_backref(tsv, sv);
3132 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3136 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3137 av = (AV*)mg->mg_obj;
3140 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3141 SvREFCNT_dec(av); /* for sv_magic */
3147 S_sv_del_backref(pTHX_ SV *sv)
3154 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3155 Perl_croak(aTHX_ "panic: del_backref");
3156 av = (AV *)mg->mg_obj;
3161 svp[i] = &PL_sv_undef; /* XXX */
3168 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3172 register char *midend;
3173 register char *bigend;
3179 Perl_croak(aTHX_ "Can't modify non-existent substring");
3180 SvPV_force(bigstr, curlen);
3181 if (offset + len > curlen) {
3182 SvGROW(bigstr, offset+len+1);
3183 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3184 SvCUR_set(bigstr, offset+len);
3187 i = littlelen - len;
3188 if (i > 0) { /* string might grow */
3189 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3190 mid = big + offset + len;
3191 midend = bigend = big + SvCUR(bigstr);
3194 while (midend > mid) /* shove everything down */
3195 *--bigend = *--midend;
3196 Move(little,big+offset,littlelen,char);
3202 Move(little,SvPVX(bigstr)+offset,len,char);
3207 big = SvPVX(bigstr);
3210 bigend = big + SvCUR(bigstr);
3212 if (midend > bigend)
3213 Perl_croak(aTHX_ "panic: sv_insert");
3215 if (mid - big > bigend - midend) { /* faster to shorten from end */
3217 Move(little, mid, littlelen,char);
3220 i = bigend - midend;
3222 Move(midend, mid, i,char);
3226 SvCUR_set(bigstr, mid - big);
3229 else if (i = mid - big) { /* faster from front */
3230 midend -= littlelen;
3232 sv_chop(bigstr,midend-i);
3237 Move(little, mid, littlelen,char);
3239 else if (littlelen) {
3240 midend -= littlelen;
3241 sv_chop(bigstr,midend);
3242 Move(little,midend,littlelen,char);
3245 sv_chop(bigstr,midend);
3250 /* make sv point to what nstr did */
3253 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3256 U32 refcnt = SvREFCNT(sv);
3257 SV_CHECK_THINKFIRST(sv);
3258 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3259 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3260 if (SvMAGICAL(sv)) {
3264 sv_upgrade(nsv, SVt_PVMG);
3265 SvMAGIC(nsv) = SvMAGIC(sv);
3266 SvFLAGS(nsv) |= SvMAGICAL(sv);
3272 assert(!SvREFCNT(sv));
3273 StructCopy(nsv,sv,SV);
3274 SvREFCNT(sv) = refcnt;
3275 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3280 Perl_sv_clear(pTHX_ register SV *sv)
3284 assert(SvREFCNT(sv) == 0);
3288 if (PL_defstash) { /* Still have a symbol table? */
3293 Zero(&tmpref, 1, SV);
3294 sv_upgrade(&tmpref, SVt_RV);
3296 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3297 SvREFCNT(&tmpref) = 1;
3300 stash = SvSTASH(sv);
3301 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3304 PUSHSTACKi(PERLSI_DESTROY);
3305 SvRV(&tmpref) = SvREFCNT_inc(sv);
3310 call_sv((SV*)GvCV(destructor),
3311 G_DISCARD|G_EVAL|G_KEEPERR);
3317 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3319 del_XRV(SvANY(&tmpref));
3322 if (PL_in_clean_objs)
3323 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3325 /* DESTROY gave object new lease on life */
3331 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3332 SvOBJECT_off(sv); /* Curse the object. */
3333 if (SvTYPE(sv) != SVt_PVIO)
3334 --PL_sv_objcount; /* XXX Might want something more general */
3337 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3340 switch (SvTYPE(sv)) {
3343 IoIFP(sv) != PerlIO_stdin() &&
3344 IoIFP(sv) != PerlIO_stdout() &&
3345 IoIFP(sv) != PerlIO_stderr())
3347 io_close((IO*)sv, FALSE);
3349 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3350 PerlDir_close(IoDIRP(sv));
3351 IoDIRP(sv) = (DIR*)NULL;
3352 Safefree(IoTOP_NAME(sv));
3353 Safefree(IoFMT_NAME(sv));
3354 Safefree(IoBOTTOM_NAME(sv));
3369 SvREFCNT_dec(LvTARG(sv));
3373 Safefree(GvNAME(sv));
3374 /* cannot decrease stash refcount yet, as we might recursively delete
3375 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3376 of stash until current sv is completely gone.
3377 -- JohnPC, 27 Mar 1998 */
3378 stash = GvSTASH(sv);
3384 (void)SvOOK_off(sv);
3392 SvREFCNT_dec(SvRV(sv));
3394 else if (SvPVX(sv) && SvLEN(sv))
3395 Safefree(SvPVX(sv));
3405 switch (SvTYPE(sv)) {
3421 del_XPVIV(SvANY(sv));
3424 del_XPVNV(SvANY(sv));
3427 del_XPVMG(SvANY(sv));
3430 del_XPVLV(SvANY(sv));
3433 del_XPVAV(SvANY(sv));
3436 del_XPVHV(SvANY(sv));
3439 del_XPVCV(SvANY(sv));
3442 del_XPVGV(SvANY(sv));
3443 /* code duplication for increased performance. */
3444 SvFLAGS(sv) &= SVf_BREAK;
3445 SvFLAGS(sv) |= SVTYPEMASK;
3446 /* decrease refcount of the stash that owns this GV, if any */
3448 SvREFCNT_dec(stash);
3449 return; /* not break, SvFLAGS reset already happened */
3451 del_XPVBM(SvANY(sv));
3454 del_XPVFM(SvANY(sv));
3457 del_XPVIO(SvANY(sv));
3460 SvFLAGS(sv) &= SVf_BREAK;
3461 SvFLAGS(sv) |= SVTYPEMASK;
3465 Perl_sv_newref(pTHX_ SV *sv)
3468 ATOMIC_INC(SvREFCNT(sv));
3473 Perl_sv_free(pTHX_ SV *sv)
3476 int refcount_is_zero;
3480 if (SvREFCNT(sv) == 0) {
3481 if (SvFLAGS(sv) & SVf_BREAK)
3483 if (PL_in_clean_all) /* All is fair */
3485 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3486 /* make sure SvREFCNT(sv)==0 happens very seldom */
3487 SvREFCNT(sv) = (~(U32)0)/2;
3490 if (ckWARN_d(WARN_INTERNAL))
3491 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3494 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3495 if (!refcount_is_zero)
3499 if (ckWARN_d(WARN_DEBUGGING))
3500 Perl_warner(aTHX_ WARN_DEBUGGING,
3501 "Attempt to free temp prematurely: SV 0x%"UVxf,
3506 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3507 /* make sure SvREFCNT(sv)==0 happens very seldom */
3508 SvREFCNT(sv) = (~(U32)0)/2;
3517 Perl_sv_len(pTHX_ register SV *sv)
3526 len = mg_length(sv);
3528 junk = SvPV(sv, len);
3533 Perl_sv_len_utf8(pTHX_ register SV *sv)
3544 len = mg_length(sv);
3547 s = (U8*)SvPV(sv, len);
3558 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3563 I32 uoffset = *offsetp;
3569 start = s = (U8*)SvPV(sv, len);
3571 while (s < send && uoffset--)
3575 *offsetp = s - start;
3579 while (s < send && ulen--)
3589 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3598 s = (U8*)SvPV(sv, len);
3600 Perl_croak(aTHX_ "panic: bad byte offset");
3601 send = s + *offsetp;
3609 if (ckWARN_d(WARN_UTF8))
3610 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3618 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3630 pv1 = SvPV(str1, cur1);
3635 pv2 = SvPV(str2, cur2);
3640 return memEQ(pv1, pv2, cur1);
3644 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3647 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3649 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3653 return cur2 ? -1 : 0;
3658 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3661 return retval < 0 ? -1 : 1;
3666 return cur1 < cur2 ? -1 : 1;
3670 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3672 #ifdef USE_LOCALE_COLLATE
3678 if (PL_collation_standard)
3682 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3684 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3686 if (!pv1 || !len1) {
3697 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3700 return retval < 0 ? -1 : 1;
3703 * When the result of collation is equality, that doesn't mean
3704 * that there are no differences -- some locales exclude some
3705 * characters from consideration. So to avoid false equalities,
3706 * we use the raw string as a tiebreaker.
3712 #endif /* USE_LOCALE_COLLATE */
3714 return sv_cmp(sv1, sv2);
3717 #ifdef USE_LOCALE_COLLATE
3719 * Any scalar variable may carry an 'o' magic that contains the
3720 * scalar data of the variable transformed to such a format that
3721 * a normal memory comparison can be used to compare the data
3722 * according to the locale settings.
3725 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
3729 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
3730 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
3735 Safefree(mg->mg_ptr);
3737 if ((xf = mem_collxfrm(s, len, &xlen))) {
3738 if (SvREADONLY(sv)) {
3741 return xf + sizeof(PL_collation_ix);
3744 sv_magic(sv, 0, 'o', 0, 0);
3745 mg = mg_find(sv, 'o');
3758 if (mg && mg->mg_ptr) {
3760 return mg->mg_ptr + sizeof(PL_collation_ix);
3768 #endif /* USE_LOCALE_COLLATE */
3771 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
3776 register STDCHAR rslast;
3777 register STDCHAR *bp;
3781 SV_CHECK_THINKFIRST(sv);
3782 (void)SvUPGRADE(sv, SVt_PV);
3786 if (RsSNARF(PL_rs)) {
3790 else if (RsRECORD(PL_rs)) {
3791 I32 recsize, bytesread;
3794 /* Grab the size of the record we're getting */
3795 recsize = SvIV(SvRV(PL_rs));
3796 (void)SvPOK_only(sv); /* Validate pointer */
3797 buffer = SvGROW(sv, recsize + 1);
3800 /* VMS wants read instead of fread, because fread doesn't respect */
3801 /* RMS record boundaries. This is not necessarily a good thing to be */
3802 /* doing, but we've got no other real choice */
3803 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
3805 bytesread = PerlIO_read(fp, buffer, recsize);
3807 SvCUR_set(sv, bytesread);
3808 buffer[bytesread] = '\0';
3809 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
3811 else if (RsPARA(PL_rs)) {
3816 rsptr = SvPV(PL_rs, rslen);
3817 rslast = rslen ? rsptr[rslen - 1] : '\0';
3819 if (RsPARA(PL_rs)) { /* have to do this both before and after */
3820 do { /* to make sure file boundaries work right */
3823 i = PerlIO_getc(fp);
3827 PerlIO_ungetc(fp,i);
3833 /* See if we know enough about I/O mechanism to cheat it ! */
3835 /* This used to be #ifdef test - it is made run-time test for ease
3836 of abstracting out stdio interface. One call should be cheap
3837 enough here - and may even be a macro allowing compile
3841 if (PerlIO_fast_gets(fp)) {
3844 * We're going to steal some values from the stdio struct
3845 * and put EVERYTHING in the innermost loop into registers.
3847 register STDCHAR *ptr;
3851 #if defined(VMS) && defined(PERLIO_IS_STDIO)
3852 /* An ungetc()d char is handled separately from the regular
3853 * buffer, so we getc() it back out and stuff it in the buffer.
3855 i = PerlIO_getc(fp);
3856 if (i == EOF) return 0;
3857 *(--((*fp)->_ptr)) = (unsigned char) i;
3861 /* Here is some breathtakingly efficient cheating */
3863 cnt = PerlIO_get_cnt(fp); /* get count into register */
3864 (void)SvPOK_only(sv); /* validate pointer */
3865 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
3866 if (cnt > 80 && SvLEN(sv) > append) {
3867 shortbuffered = cnt - SvLEN(sv) + append + 1;
3868 cnt -= shortbuffered;
3872 /* remember that cnt can be negative */
3873 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
3878 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
3879 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
3880 DEBUG_P(PerlIO_printf(Perl_debug_log,
3881 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3882 DEBUG_P(PerlIO_printf(Perl_debug_log,
3883 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3884 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3885 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
3890 while (cnt > 0) { /* this | eat */
3892 if ((*bp++ = *ptr++) == rslast) /* really | dust */
3893 goto thats_all_folks; /* screams | sed :-) */
3897 Copy(ptr, bp, cnt, char); /* this | eat */
3898 bp += cnt; /* screams | dust */
3899 ptr += cnt; /* louder | sed :-) */
3904 if (shortbuffered) { /* oh well, must extend */
3905 cnt = shortbuffered;
3907 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3909 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
3910 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3914 DEBUG_P(PerlIO_printf(Perl_debug_log,
3915 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
3916 PTR2UV(ptr),(long)cnt));
3917 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
3918 DEBUG_P(PerlIO_printf(Perl_debug_log,
3919 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3920 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3921 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3922 /* This used to call 'filbuf' in stdio form, but as that behaves like
3923 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
3924 another abstraction. */
3925 i = PerlIO_getc(fp); /* get more characters */
3926 DEBUG_P(PerlIO_printf(Perl_debug_log,
3927 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3928 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3929 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3930 cnt = PerlIO_get_cnt(fp);
3931 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
3932 DEBUG_P(PerlIO_printf(Perl_debug_log,
3933 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3935 if (i == EOF) /* all done for ever? */
3936 goto thats_really_all_folks;
3938 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
3940 SvGROW(sv, bpx + cnt + 2);
3941 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
3943 *bp++ = i; /* store character from PerlIO_getc */
3945 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
3946 goto thats_all_folks;
3950 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
3951 memNE((char*)bp - rslen, rsptr, rslen))
3952 goto screamer; /* go back to the fray */
3953 thats_really_all_folks:
3955 cnt += shortbuffered;
3956 DEBUG_P(PerlIO_printf(Perl_debug_log,
3957 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
3958 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
3959 DEBUG_P(PerlIO_printf(Perl_debug_log,
3960 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
3961 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
3962 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
3964 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
3965 DEBUG_P(PerlIO_printf(Perl_debug_log,
3966 "Screamer: done, len=%ld, string=|%.*s|\n",
3967 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
3972 /*The big, slow, and stupid way */
3975 /* Need to work around EPOC SDK features */
3976 /* On WINS: MS VC5 generates calls to _chkstk, */
3977 /* if a `large' stack frame is allocated */
3978 /* gcc on MARM does not generate calls like these */
3984 register STDCHAR *bpe = buf + sizeof(buf);
3986 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
3987 ; /* keep reading */
3991 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
3992 /* Accomodate broken VAXC compiler, which applies U8 cast to
3993 * both args of ?: operator, causing EOF to change into 255
3995 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
3999 sv_catpvn(sv, (char *) buf, cnt);
4001 sv_setpvn(sv, (char *) buf, cnt);
4003 if (i != EOF && /* joy */
4005 SvCUR(sv) < rslen ||
4006 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4010 * If we're reading from a TTY and we get a short read,
4011 * indicating that the user hit his EOF character, we need
4012 * to notice it now, because if we try to read from the TTY
4013 * again, the EOF condition will disappear.
4015 * The comparison of cnt to sizeof(buf) is an optimization
4016 * that prevents unnecessary calls to feof().
4020 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4025 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4026 while (i != EOF) { /* to make sure file boundaries work right */
4027 i = PerlIO_getc(fp);
4029 PerlIO_ungetc(fp,i);
4036 win32_strip_return(sv);
4039 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4044 Perl_sv_inc(pTHX_ register SV *sv)
4053 if (SvTHINKFIRST(sv)) {
4054 if (SvREADONLY(sv)) {
4056 if (PL_curcop != &PL_compiling)
4057 Perl_croak(aTHX_ PL_no_modify);
4061 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4063 i = PTR2IV(SvRV(sv));
4068 flags = SvFLAGS(sv);
4069 if (flags & SVp_NOK) {
4070 (void)SvNOK_only(sv);
4074 if (flags & SVp_IOK) {
4076 if (SvUVX(sv) == UV_MAX)
4077 sv_setnv(sv, (NV)UV_MAX + 1.0);
4079 (void)SvIOK_only_UV(sv);
4082 if (SvIVX(sv) == IV_MAX)
4083 sv_setnv(sv, (NV)IV_MAX + 1.0);
4085 (void)SvIOK_only(sv);
4091 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4092 if ((flags & SVTYPEMASK) < SVt_PVNV)
4093 sv_upgrade(sv, SVt_NV);
4095 (void)SvNOK_only(sv);
4099 while (isALPHA(*d)) d++;
4100 while (isDIGIT(*d)) d++;
4102 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4106 while (d >= SvPVX(sv)) {
4114 /* MKS: The original code here died if letters weren't consecutive.
4115 * at least it didn't have to worry about non-C locales. The
4116 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4117 * arranged in order (although not consecutively) and that only
4118 * [A-Za-z] are accepted by isALPHA in the C locale.
4120 if (*d != 'z' && *d != 'Z') {
4121 do { ++*d; } while (!isALPHA(*d));
4124 *(d--) -= 'z' - 'a';
4129 *(d--) -= 'z' - 'a' + 1;
4133 /* oh,oh, the number grew */
4134 SvGROW(sv, SvCUR(sv) + 2);
4136 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4145 Perl_sv_dec(pTHX_ register SV *sv)
4153 if (SvTHINKFIRST(sv)) {
4154 if (SvREADONLY(sv)) {
4156 if (PL_curcop != &PL_compiling)
4157 Perl_croak(aTHX_ PL_no_modify);
4161 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4163 i = PTR2IV(SvRV(sv));
4168 flags = SvFLAGS(sv);
4169 if (flags & SVp_NOK) {
4171 (void)SvNOK_only(sv);
4174 if (flags & SVp_IOK) {
4176 if (SvUVX(sv) == 0) {
4177 (void)SvIOK_only(sv);
4181 (void)SvIOK_only_UV(sv);
4185 if (SvIVX(sv) == IV_MIN)
4186 sv_setnv(sv, (NV)IV_MIN - 1.0);
4188 (void)SvIOK_only(sv);
4194 if (!(flags & SVp_POK)) {
4195 if ((flags & SVTYPEMASK) < SVt_PVNV)
4196 sv_upgrade(sv, SVt_NV);
4198 (void)SvNOK_only(sv);
4201 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4204 /* Make a string that will exist for the duration of the expression
4205 * evaluation. Actually, it may have to last longer than that, but
4206 * hopefully we won't free it until it has been assigned to a
4207 * permanent location. */
4210 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4216 sv_setsv(sv,oldstr);
4218 PL_tmps_stack[++PL_tmps_ix] = sv;
4224 Perl_sv_newmortal(pTHX)
4230 SvFLAGS(sv) = SVs_TEMP;
4232 PL_tmps_stack[++PL_tmps_ix] = sv;
4236 /* same thing without the copying */
4239 Perl_sv_2mortal(pTHX_ register SV *sv)
4244 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4247 PL_tmps_stack[++PL_tmps_ix] = sv;
4253 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4260 sv_setpvn(sv,s,len);
4265 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4270 sv_setpvn(sv,s,len);
4274 #if defined(PERL_IMPLICIT_CONTEXT)
4276 Perl_newSVpvf_nocontext(const char* pat, ...)
4281 va_start(args, pat);
4282 sv = vnewSVpvf(pat, &args);
4289 Perl_newSVpvf(pTHX_ const char* pat, ...)
4293 va_start(args, pat);
4294 sv = vnewSVpvf(pat, &args);
4300 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4304 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4309 Perl_newSVnv(pTHX_ NV n)
4319 Perl_newSViv(pTHX_ IV i)
4329 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4335 sv_upgrade(sv, SVt_RV);
4343 Perl_newRV(pTHX_ SV *tmpRef)
4345 return newRV_noinc(SvREFCNT_inc(tmpRef));
4348 /* make an exact duplicate of old */
4351 Perl_newSVsv(pTHX_ register SV *old)
4358 if (SvTYPE(old) == SVTYPEMASK) {
4359 if (ckWARN_d(WARN_INTERNAL))
4360 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4375 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4383 char todo[PERL_UCHAR_MAX+1];
4388 if (!*s) { /* reset ?? searches */
4389 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4390 pm->op_pmdynflags &= ~PMdf_USED;
4395 /* reset variables */
4397 if (!HvARRAY(stash))
4400 Zero(todo, 256, char);
4402 i = (unsigned char)*s;
4406 max = (unsigned char)*s++;
4407 for ( ; i <= max; i++) {
4410 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4411 for (entry = HvARRAY(stash)[i];
4413 entry = HeNEXT(entry))
4415 if (!todo[(U8)*HeKEY(entry)])
4417 gv = (GV*)HeVAL(entry);
4419 if (SvTHINKFIRST(sv)) {
4420 if (!SvREADONLY(sv) && SvROK(sv))
4425 if (SvTYPE(sv) >= SVt_PV) {
4427 if (SvPVX(sv) != Nullch)
4434 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4436 #ifndef VMS /* VMS has no environ array */
4438 environ[0] = Nullch;
4447 Perl_sv_2io(pTHX_ SV *sv)
4453 switch (SvTYPE(sv)) {
4461 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4465 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4467 return sv_2io(SvRV(sv));
4468 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4474 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4481 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4488 return *gvp = Nullgv, Nullcv;
4489 switch (SvTYPE(sv)) {
4509 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4510 tryAMAGICunDEREF(to_cv);
4513 if (SvTYPE(sv) == SVt_PVCV) {
4522 Perl_croak(aTHX_ "Not a subroutine reference");
4527 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4533 if (lref && !GvCVu(gv)) {
4536 tmpsv = NEWSV(704,0);
4537 gv_efullname3(tmpsv, gv, Nullch);
4538 /* XXX this is probably not what they think they're getting.
4539 * It has the same effect as "sub name;", i.e. just a forward
4541 newSUB(start_subparse(FALSE, 0),
4542 newSVOP(OP_CONST, 0, tmpsv),
4547 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4554 Perl_sv_true(pTHX_ register SV *sv)
4561 if ((tXpv = (XPV*)SvANY(sv)) &&
4562 (*tXpv->xpv_pv > '0' ||
4563 tXpv->xpv_cur > 1 ||
4564 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4571 return SvIVX(sv) != 0;
4574 return SvNVX(sv) != 0.0;
4576 return sv_2bool(sv);
4582 Perl_sv_iv(pTHX_ register SV *sv)
4586 return (IV)SvUVX(sv);
4593 Perl_sv_uv(pTHX_ register SV *sv)
4598 return (UV)SvIVX(sv);
4604 Perl_sv_nv(pTHX_ register SV *sv)
4612 Perl_sv_pv(pTHX_ SV *sv)
4619 return sv_2pv(sv, &n_a);
4623 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
4629 return sv_2pv(sv, lp);
4633 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
4637 if (SvTHINKFIRST(sv) && !SvROK(sv))
4638 sv_force_normal(sv);
4644 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
4646 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
4647 PL_op_name[PL_op->op_type]);
4651 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
4656 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
4657 SvGROW(sv, len + 1);
4658 Move(s,SvPVX(sv),len,char);
4663 SvPOK_on(sv); /* validate pointer */
4665 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
4666 PTR2UV(sv),SvPVX(sv)));
4673 Perl_sv_reftype(pTHX_ SV *sv, int ob)
4675 if (ob && SvOBJECT(sv))
4676 return HvNAME(SvSTASH(sv));
4678 switch (SvTYPE(sv)) {
4692 case SVt_PVLV: return "LVALUE";
4693 case SVt_PVAV: return "ARRAY";
4694 case SVt_PVHV: return "HASH";
4695 case SVt_PVCV: return "CODE";
4696 case SVt_PVGV: return "GLOB";
4697 case SVt_PVFM: return "FORMAT";
4698 default: return "UNKNOWN";
4704 Perl_sv_isobject(pTHX_ SV *sv)
4719 Perl_sv_isa(pTHX_ SV *sv, const char *name)
4731 return strEQ(HvNAME(SvSTASH(sv)), name);
4735 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
4742 SV_CHECK_THINKFIRST(rv);
4745 if (SvTYPE(rv) < SVt_RV)
4746 sv_upgrade(rv, SVt_RV);
4753 HV* stash = gv_stashpv(classname, TRUE);
4754 (void)sv_bless(rv, stash);
4760 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
4763 sv_setsv(rv, &PL_sv_undef);
4767 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
4772 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
4774 sv_setiv(newSVrv(rv,classname), iv);
4779 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
4781 sv_setnv(newSVrv(rv,classname), nv);
4786 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
4788 sv_setpvn(newSVrv(rv,classname), pv, n);
4793 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
4798 Perl_croak(aTHX_ "Can't bless non-reference value");
4800 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
4801 if (SvREADONLY(tmpRef))
4802 Perl_croak(aTHX_ PL_no_modify);
4803 if (SvOBJECT(tmpRef)) {
4804 if (SvTYPE(tmpRef) != SVt_PVIO)
4806 SvREFCNT_dec(SvSTASH(tmpRef));
4809 SvOBJECT_on(tmpRef);
4810 if (SvTYPE(tmpRef) != SVt_PVIO)
4812 (void)SvUPGRADE(tmpRef, SVt_PVMG);
4813 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
4824 S_sv_unglob(pTHX_ SV *sv)
4826 assert(SvTYPE(sv) == SVt_PVGV);
4831 SvREFCNT_dec(GvSTASH(sv));
4832 GvSTASH(sv) = Nullhv;
4834 sv_unmagic(sv, '*');
4835 Safefree(GvNAME(sv));
4837 SvFLAGS(sv) &= ~SVTYPEMASK;
4838 SvFLAGS(sv) |= SVt_PVMG;
4842 Perl_sv_unref(pTHX_ SV *sv)
4846 if (SvWEAKREF(sv)) {
4854 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
4857 sv_2mortal(rv); /* Schedule for freeing later */
4861 Perl_sv_taint(pTHX_ SV *sv)
4863 sv_magic((sv), Nullsv, 't', Nullch, 0);
4867 Perl_sv_untaint(pTHX_ SV *sv)
4869 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4870 MAGIC *mg = mg_find(sv, 't');
4877 Perl_sv_tainted(pTHX_ SV *sv)
4879 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
4880 MAGIC *mg = mg_find(sv, 't');
4881 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
4888 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
4890 char buf[TYPE_CHARS(UV)];
4892 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4894 sv_setpvn(sv, ptr, ebuf - ptr);
4899 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
4901 char buf[TYPE_CHARS(UV)];
4903 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
4905 sv_setpvn(sv, ptr, ebuf - ptr);
4909 #if defined(PERL_IMPLICIT_CONTEXT)
4911 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
4915 va_start(args, pat);
4916 sv_vsetpvf(sv, pat, &args);
4922 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
4926 va_start(args, pat);
4927 sv_vsetpvf_mg(sv, pat, &args);
4933 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
4936 va_start(args, pat);
4937 sv_vsetpvf(sv, pat, &args);
4942 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4944 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4948 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
4951 va_start(args, pat);
4952 sv_vsetpvf_mg(sv, pat, &args);
4957 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
4959 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4963 #if defined(PERL_IMPLICIT_CONTEXT)
4965 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
4969 va_start(args, pat);
4970 sv_vcatpvf(sv, pat, &args);
4975 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
4979 va_start(args, pat);
4980 sv_vcatpvf_mg(sv, pat, &args);
4986 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
4989 va_start(args, pat);
4990 sv_vcatpvf(sv, pat, &args);
4995 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
4997 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5001 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5004 va_start(args, pat);
5005 sv_vcatpvf_mg(sv, pat, &args);
5010 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5012 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5017 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5019 sv_setpvn(sv, "", 0);
5020 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5024 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5032 static char nullstr[] = "(null)";
5034 /* no matter what, this is a string now */
5035 (void)SvPV_force(sv, origlen);
5037 /* special-case "", "%s", and "%_" */
5040 if (patlen == 2 && pat[0] == '%') {
5044 char *s = va_arg(*args, char*);
5045 sv_catpv(sv, s ? s : nullstr);
5047 else if (svix < svmax)
5048 sv_catsv(sv, *svargs);
5052 sv_catsv(sv, va_arg(*args, SV*));
5055 /* See comment on '_' below */
5060 patend = (char*)pat + patlen;
5061 for (p = (char*)pat; p < patend; p = q) {
5069 bool has_precis = FALSE;
5074 STRLEN esignlen = 0;
5076 char *eptr = Nullch;
5078 /* Times 4: a decimal digit takes more than 3 binary digits.
5079 * NV_DIG: mantissa takes than many decimal digits.
5080 * Plus 32: Playing safe. */
5081 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5082 /* large enough for "%#.#f" --chip */
5083 /* what about long double NVs? --jhi */
5094 for (q = p; q < patend && *q != '%'; ++q) ;
5096 sv_catpvn(sv, p, q - p);
5134 case '1': case '2': case '3':
5135 case '4': case '5': case '6':
5136 case '7': case '8': case '9':
5139 width = width * 10 + (*q++ - '0');
5144 i = va_arg(*args, int);
5146 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5148 width = (i < 0) ? -i : i;
5159 i = va_arg(*args, int);
5161 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5162 precis = (i < 0) ? 0 : i;
5168 precis = precis * 10 + (*q++ - '0');
5185 if (*(q + 1) == 'l') { /* lld */
5213 uv = va_arg(*args, int);
5215 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5217 eptr = (char*)utf8buf;
5218 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5222 c = va_arg(*args, int);
5224 c = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5231 eptr = va_arg(*args, char*);
5233 #ifdef MACOS_TRADITIONAL
5234 /* On MacOS, %#s format is used for Pascal strings */
5239 elen = strlen(eptr);
5242 elen = sizeof nullstr - 1;
5245 else if (svix < svmax) {
5246 eptr = SvPVx(svargs[svix++], elen);
5248 if (has_precis && precis < elen) {
5250 sv_pos_u2b(svargs[svix - 1], &p, 0); /* sticks at end */
5253 if (width) { /* fudge width (can't fudge elen) */
5254 width += elen - sv_len_utf8(svargs[svix - 1]);
5262 * The "%_" hack might have to be changed someday,
5263 * if ISO or ANSI decide to use '_' for something.
5264 * So we keep it hidden from users' code.
5268 eptr = SvPVx(va_arg(*args, SV*), elen);
5271 if (has_precis && elen > precis)
5279 uv = PTR2UV(va_arg(*args, void*));
5281 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5296 case 'h': iv = (short)va_arg(*args, int); break;
5297 default: iv = va_arg(*args, int); break;
5298 case 'l': iv = va_arg(*args, long); break;
5299 case 'V': iv = va_arg(*args, IV); break;
5301 case 'q': iv = va_arg(*args, Quad_t); break;
5306 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5308 case 'h': iv = (short)iv; break;
5309 default: iv = (int)iv; break;
5310 case 'l': iv = (long)iv; break;
5313 case 'q': iv = (Quad_t)iv; break;
5320 esignbuf[esignlen++] = plus;
5324 esignbuf[esignlen++] = '-';
5362 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5363 default: uv = va_arg(*args, unsigned); break;
5364 case 'l': uv = va_arg(*args, unsigned long); break;
5365 case 'V': uv = va_arg(*args, UV); break;
5367 case 'q': uv = va_arg(*args, Quad_t); break;
5372 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5374 case 'h': uv = (unsigned short)uv; break;
5375 default: uv = (unsigned)uv; break;
5376 case 'l': uv = (unsigned long)uv; break;
5379 case 'q': uv = (Quad_t)uv; break;
5385 eptr = ebuf + sizeof ebuf;
5391 p = (char*)((c == 'X')
5392 ? "0123456789ABCDEF" : "0123456789abcdef");
5398 esignbuf[esignlen++] = '0';
5399 esignbuf[esignlen++] = c; /* 'x' or 'X' */
5405 *--eptr = '0' + dig;
5407 if (alt && *eptr != '0')
5413 *--eptr = '0' + dig;
5416 esignbuf[esignlen++] = '0';
5417 esignbuf[esignlen++] = 'b';
5420 default: /* it had better be ten or less */
5421 #if defined(PERL_Y2KWARN)
5422 if (ckWARN(WARN_MISC)) {
5424 char *s = SvPV(sv,n);
5425 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
5426 && (n == 2 || !isDIGIT(s[n-3])))
5428 Perl_warner(aTHX_ WARN_MISC,
5429 "Possible Y2K bug: %%%c %s",
5430 c, "format string following '19'");
5436 *--eptr = '0' + dig;
5437 } while (uv /= base);
5440 elen = (ebuf + sizeof ebuf) - eptr;
5443 zeros = precis - elen;
5444 else if (precis == 0 && elen == 1 && *eptr == '0')
5449 /* FLOATING POINT */
5452 c = 'f'; /* maybe %F isn't supported here */
5458 /* This is evil, but floating point is even more evil */
5461 nv = va_arg(*args, NV);
5463 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
5466 if (c != 'e' && c != 'E') {
5468 (void)frexp(nv, &i);
5469 if (i == PERL_INT_MIN)
5470 Perl_die(aTHX_ "panic: frexp");
5472 need = BIT_DIGITS(i);
5474 need += has_precis ? precis : 6; /* known default */
5478 need += 20; /* fudge factor */
5479 if (PL_efloatsize < need) {
5480 Safefree(PL_efloatbuf);
5481 PL_efloatsize = need + 20; /* more fudge */
5482 New(906, PL_efloatbuf, PL_efloatsize, char);
5483 PL_efloatbuf[0] = '\0';
5486 eptr = ebuf + sizeof ebuf;
5489 #ifdef USE_LONG_DOUBLE
5491 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
5492 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
5497 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5502 do { *--eptr = '0' + (base % 10); } while (base /= 10);
5515 RESTORE_NUMERIC_STANDARD();
5516 (void)sprintf(PL_efloatbuf, eptr, nv);
5517 RESTORE_NUMERIC_LOCAL();
5520 eptr = PL_efloatbuf;
5521 elen = strlen(PL_efloatbuf);
5527 i = SvCUR(sv) - origlen;
5530 case 'h': *(va_arg(*args, short*)) = i; break;
5531 default: *(va_arg(*args, int*)) = i; break;
5532 case 'l': *(va_arg(*args, long*)) = i; break;
5533 case 'V': *(va_arg(*args, IV*)) = i; break;
5535 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
5539 else if (svix < svmax)
5540 sv_setuv(svargs[svix++], (UV)i);
5541 continue; /* not "break" */
5547 if (!args && ckWARN(WARN_PRINTF) &&
5548 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
5549 SV *msg = sv_newmortal();
5550 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
5551 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
5554 Perl_sv_catpvf(aTHX_ msg,
5555 "\"%%%c\"", c & 0xFF);
5557 Perl_sv_catpvf(aTHX_ msg,
5558 "\"%%\\%03"UVof"\"",
5561 sv_catpv(msg, "end of string");
5562 Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */
5565 /* output mangled stuff ... */
5571 /* ... right here, because formatting flags should not apply */
5572 SvGROW(sv, SvCUR(sv) + elen + 1);
5574 memcpy(p, eptr, elen);
5577 SvCUR(sv) = p - SvPVX(sv);
5578 continue; /* not "break" */
5581 have = esignlen + zeros + elen;
5582 need = (have > width ? have : width);
5585 SvGROW(sv, SvCUR(sv) + need + 1);
5587 if (esignlen && fill == '0') {
5588 for (i = 0; i < esignlen; i++)
5592 memset(p, fill, gap);
5595 if (esignlen && fill != '0') {
5596 for (i = 0; i < esignlen; i++)
5600 for (i = zeros; i; i--)
5604 memcpy(p, eptr, elen);
5608 memset(p, ' ', gap);
5612 SvCUR(sv) = p - SvPVX(sv);
5616 #if defined(USE_ITHREADS)
5618 #if defined(USE_THREADS)
5619 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
5622 #ifndef OpREFCNT_inc
5623 # define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop)
5626 #ifndef GpREFCNT_inc
5627 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
5631 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
5632 #define av_dup(s) (AV*)sv_dup((SV*)s)
5633 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
5634 #define hv_dup(s) (HV*)sv_dup((SV*)s)
5635 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
5636 #define cv_dup(s) (CV*)sv_dup((SV*)s)
5637 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
5638 #define io_dup(s) (IO*)sv_dup((SV*)s)
5639 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
5640 #define gv_dup(s) (GV*)sv_dup((SV*)s)
5641 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
5642 #define SAVEPV(p) (p ? savepv(p) : Nullch)
5643 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
5646 Perl_re_dup(pTHX_ REGEXP *r)
5648 /* XXX fix when pmop->op_pmregexp becomes shared */
5649 return ReREFCNT_inc(r);
5653 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
5657 return (PerlIO*)NULL;
5659 /* look for it in the table first */
5660 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
5664 /* create anew and remember what it is */
5665 ret = PerlIO_fdupopen(fp);
5666 ptr_table_store(PL_ptr_table, fp, ret);
5671 Perl_dirp_dup(pTHX_ DIR *dp)
5680 Perl_gp_dup(pTHX_ GP *gp)
5685 /* look for it in the table first */
5686 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
5690 /* create anew and remember what it is */
5691 Newz(0, ret, 1, GP);
5692 ptr_table_store(PL_ptr_table, gp, ret);
5695 ret->gp_refcnt = 0; /* must be before any other dups! */
5696 ret->gp_sv = sv_dup_inc(gp->gp_sv);
5697 ret->gp_io = io_dup_inc(gp->gp_io);
5698 ret->gp_form = cv_dup_inc(gp->gp_form);
5699 ret->gp_av = av_dup_inc(gp->gp_av);
5700 ret->gp_hv = hv_dup_inc(gp->gp_hv);
5701 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
5702 ret->gp_cv = cv_dup_inc(gp->gp_cv);
5703 ret->gp_cvgen = gp->gp_cvgen;
5704 ret->gp_flags = gp->gp_flags;
5705 ret->gp_line = gp->gp_line;
5706 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
5711 Perl_mg_dup(pTHX_ MAGIC *mg)
5713 MAGIC *mgret = (MAGIC*)NULL;
5716 return (MAGIC*)NULL;
5717 /* look for it in the table first */
5718 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
5722 for (; mg; mg = mg->mg_moremagic) {
5724 Newz(0, nmg, 1, MAGIC);
5728 mgprev->mg_moremagic = nmg;
5729 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
5730 nmg->mg_private = mg->mg_private;
5731 nmg->mg_type = mg->mg_type;
5732 nmg->mg_flags = mg->mg_flags;
5733 if (mg->mg_type == 'r') {
5734 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
5737 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
5738 ? sv_dup_inc(mg->mg_obj)
5739 : sv_dup(mg->mg_obj);
5741 nmg->mg_len = mg->mg_len;
5742 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
5743 if (mg->mg_ptr && mg->mg_type != 'g') {
5744 if (mg->mg_len >= 0) {
5745 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
5746 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
5747 AMT *amtp = (AMT*)mg->mg_ptr;
5748 AMT *namtp = (AMT*)nmg->mg_ptr;
5750 for (i = 1; i < NofAMmeth; i++) {
5751 namtp->table[i] = cv_dup_inc(amtp->table[i]);
5755 else if (mg->mg_len == HEf_SVKEY)
5756 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
5764 Perl_ptr_table_new(pTHX)
5767 Newz(0, tbl, 1, PTR_TBL_t);
5770 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
5775 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
5777 PTR_TBL_ENT_t *tblent;
5780 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
5781 for (; tblent; tblent = tblent->next) {
5782 if (tblent->oldval == sv)
5783 return tblent->newval;
5789 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
5791 PTR_TBL_ENT_t *tblent, **otblent;
5792 /* XXX this may be pessimal on platforms where pointers aren't good
5793 * hash values e.g. if they grow faster in the most significant
5799 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
5800 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
5801 if (tblent->oldval == oldv) {
5802 tblent->newval = newv;
5807 Newz(0, tblent, 1, PTR_TBL_ENT_t);
5808 tblent->oldval = oldv;
5809 tblent->newval = newv;
5810 tblent->next = *otblent;
5813 if (i && tbl->tbl_items > tbl->tbl_max)
5814 ptr_table_split(tbl);
5818 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
5820 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
5821 UV oldsize = tbl->tbl_max + 1;
5822 UV newsize = oldsize * 2;
5825 Renew(ary, newsize, PTR_TBL_ENT_t*);
5826 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
5827 tbl->tbl_max = --newsize;
5829 for (i=0; i < oldsize; i++, ary++) {
5830 PTR_TBL_ENT_t **curentp, **entp, *ent;
5833 curentp = ary + oldsize;
5834 for (entp = ary, ent = *ary; ent; ent = *entp) {
5835 if ((newsize & (UV)ent->oldval) != i) {
5837 ent->next = *curentp;
5852 Perl_sv_dup(pTHX_ SV *sstr)
5859 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
5861 /* look for it in the table first */
5862 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
5866 /* create anew and remember what it is */
5868 ptr_table_store(PL_ptr_table, sstr, dstr);
5871 SvFLAGS(dstr) = SvFLAGS(sstr);
5872 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
5873 SvREFCNT(dstr) = 0; /* must be before any other dups! */
5876 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
5877 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
5878 PL_watch_pvx, SvPVX(sstr));
5881 switch (SvTYPE(sstr)) {
5886 SvANY(dstr) = new_XIV();
5887 SvIVX(dstr) = SvIVX(sstr);
5890 SvANY(dstr) = new_XNV();
5891 SvNVX(dstr) = SvNVX(sstr);
5894 SvANY(dstr) = new_XRV();
5895 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5898 SvANY(dstr) = new_XPV();
5899 SvCUR(dstr) = SvCUR(sstr);
5900 SvLEN(dstr) = SvLEN(sstr);
5902 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5903 else if (SvPVX(sstr) && SvLEN(sstr))
5904 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5906 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5909 SvANY(dstr) = new_XPVIV();
5910 SvCUR(dstr) = SvCUR(sstr);
5911 SvLEN(dstr) = SvLEN(sstr);
5912 SvIVX(dstr) = SvIVX(sstr);
5914 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5915 else if (SvPVX(sstr) && SvLEN(sstr))
5916 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5918 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5921 SvANY(dstr) = new_XPVNV();
5922 SvCUR(dstr) = SvCUR(sstr);
5923 SvLEN(dstr) = SvLEN(sstr);
5924 SvIVX(dstr) = SvIVX(sstr);
5925 SvNVX(dstr) = SvNVX(sstr);
5927 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5928 else if (SvPVX(sstr) && SvLEN(sstr))
5929 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5931 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5934 SvANY(dstr) = new_XPVMG();
5935 SvCUR(dstr) = SvCUR(sstr);
5936 SvLEN(dstr) = SvLEN(sstr);
5937 SvIVX(dstr) = SvIVX(sstr);
5938 SvNVX(dstr) = SvNVX(sstr);
5939 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5940 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5942 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5943 else if (SvPVX(sstr) && SvLEN(sstr))
5944 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5946 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5949 SvANY(dstr) = new_XPVBM();
5950 SvCUR(dstr) = SvCUR(sstr);
5951 SvLEN(dstr) = SvLEN(sstr);
5952 SvIVX(dstr) = SvIVX(sstr);
5953 SvNVX(dstr) = SvNVX(sstr);
5954 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5955 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5957 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5958 else if (SvPVX(sstr) && SvLEN(sstr))
5959 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5961 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5962 BmRARE(dstr) = BmRARE(sstr);
5963 BmUSEFUL(dstr) = BmUSEFUL(sstr);
5964 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
5967 SvANY(dstr) = new_XPVLV();
5968 SvCUR(dstr) = SvCUR(sstr);
5969 SvLEN(dstr) = SvLEN(sstr);
5970 SvIVX(dstr) = SvIVX(sstr);
5971 SvNVX(dstr) = SvNVX(sstr);
5972 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5973 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5975 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5976 else if (SvPVX(sstr) && SvLEN(sstr))
5977 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5979 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5980 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
5981 LvTARGLEN(dstr) = LvTARGLEN(sstr);
5982 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
5983 LvTYPE(dstr) = LvTYPE(sstr);
5986 SvANY(dstr) = new_XPVGV();
5987 SvCUR(dstr) = SvCUR(sstr);
5988 SvLEN(dstr) = SvLEN(sstr);
5989 SvIVX(dstr) = SvIVX(sstr);
5990 SvNVX(dstr) = SvNVX(sstr);
5991 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
5992 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
5994 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
5995 else if (SvPVX(sstr) && SvLEN(sstr))
5996 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
5998 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
5999 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6000 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6001 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6002 GvFLAGS(dstr) = GvFLAGS(sstr);
6003 GvGP(dstr) = gp_dup(GvGP(sstr));
6004 (void)GpREFCNT_inc(GvGP(dstr));
6007 SvANY(dstr) = new_XPVIO();
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 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6021 if (IoOFP(sstr) == IoIFP(sstr))
6022 IoOFP(dstr) = IoIFP(dstr);
6024 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6025 /* PL_rsfp_filters entries have fake IoDIRP() */
6026 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6027 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6029 IoDIRP(dstr) = IoDIRP(sstr);
6030 IoLINES(dstr) = IoLINES(sstr);
6031 IoPAGE(dstr) = IoPAGE(sstr);
6032 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6033 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6034 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6035 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6036 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6037 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6038 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6039 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6040 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6041 IoTYPE(dstr) = IoTYPE(sstr);
6042 IoFLAGS(dstr) = IoFLAGS(sstr);
6045 SvANY(dstr) = new_XPVAV();
6046 SvCUR(dstr) = SvCUR(sstr);
6047 SvLEN(dstr) = SvLEN(sstr);
6048 SvIVX(dstr) = SvIVX(sstr);
6049 SvNVX(dstr) = SvNVX(sstr);
6050 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6051 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6052 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6053 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6054 if (AvARRAY((AV*)sstr)) {
6055 SV **dst_ary, **src_ary;
6056 SSize_t items = AvFILLp((AV*)sstr) + 1;
6058 src_ary = AvARRAY((AV*)sstr);
6059 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6060 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6061 SvPVX(dstr) = (char*)dst_ary;
6062 AvALLOC((AV*)dstr) = dst_ary;
6063 if (AvREAL((AV*)sstr)) {
6065 *dst_ary++ = sv_dup_inc(*src_ary++);
6069 *dst_ary++ = sv_dup(*src_ary++);
6071 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6072 while (items-- > 0) {
6073 *dst_ary++ = &PL_sv_undef;
6077 SvPVX(dstr) = Nullch;
6078 AvALLOC((AV*)dstr) = (SV**)NULL;
6082 SvANY(dstr) = new_XPVHV();
6083 SvCUR(dstr) = SvCUR(sstr);
6084 SvLEN(dstr) = SvLEN(sstr);
6085 SvIVX(dstr) = SvIVX(sstr);
6086 SvNVX(dstr) = SvNVX(sstr);
6087 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6088 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6089 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6090 if (HvARRAY((HV*)sstr)) {
6093 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6094 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6095 Newz(0, dxhv->xhv_array,
6096 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6097 while (i <= sxhv->xhv_max) {
6098 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6099 !!HvSHAREKEYS(sstr));
6102 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6105 SvPVX(dstr) = Nullch;
6106 HvEITER((HV*)dstr) = (HE*)NULL;
6108 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6109 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6112 SvANY(dstr) = new_XPVFM();
6113 FmLINES(dstr) = FmLINES(sstr);
6117 SvANY(dstr) = new_XPVCV();
6119 SvCUR(dstr) = SvCUR(sstr);
6120 SvLEN(dstr) = SvLEN(sstr);
6121 SvIVX(dstr) = SvIVX(sstr);
6122 SvNVX(dstr) = SvNVX(sstr);
6123 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6124 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6125 if (SvPVX(sstr) && SvLEN(sstr))
6126 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6128 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6129 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6130 CvSTART(dstr) = CvSTART(sstr);
6131 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6132 CvXSUB(dstr) = CvXSUB(sstr);
6133 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6134 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6135 CvDEPTH(dstr) = CvDEPTH(sstr);
6136 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6137 /* XXX padlists are real, but pretend to be not */
6138 AvREAL_on(CvPADLIST(sstr));
6139 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6140 AvREAL_off(CvPADLIST(sstr));
6141 AvREAL_off(CvPADLIST(dstr));
6144 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6145 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6146 CvFLAGS(dstr) = CvFLAGS(sstr);
6149 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6153 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6160 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6165 return (PERL_CONTEXT*)NULL;
6167 /* look for it in the table first */
6168 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6172 /* create anew and remember what it is */
6173 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6174 ptr_table_store(PL_ptr_table, cxs, ncxs);
6177 PERL_CONTEXT *cx = &cxs[ix];
6178 PERL_CONTEXT *ncx = &ncxs[ix];
6179 ncx->cx_type = cx->cx_type;
6180 if (CxTYPE(cx) == CXt_SUBST) {
6181 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6184 ncx->blk_oldsp = cx->blk_oldsp;
6185 ncx->blk_oldcop = cx->blk_oldcop;
6186 ncx->blk_oldretsp = cx->blk_oldretsp;
6187 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6188 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6189 ncx->blk_oldpm = cx->blk_oldpm;
6190 ncx->blk_gimme = cx->blk_gimme;
6191 switch (CxTYPE(cx)) {
6193 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6194 ? cv_dup_inc(cx->blk_sub.cv)
6195 : cv_dup(cx->blk_sub.cv));
6196 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6197 ? av_dup_inc(cx->blk_sub.argarray)
6199 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6200 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6201 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6202 ncx->blk_sub.lval = cx->blk_sub.lval;
6205 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6206 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6207 ncx->blk_eval.old_name = SAVEPV(cx->blk_eval.old_name);
6208 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6209 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
6212 ncx->blk_loop.label = cx->blk_loop.label;
6213 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
6214 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
6215 ncx->blk_loop.next_op = cx->blk_loop.next_op;
6216 ncx->blk_loop.last_op = cx->blk_loop.last_op;
6217 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
6218 ? cx->blk_loop.iterdata
6219 : gv_dup((GV*)cx->blk_loop.iterdata));
6220 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
6221 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
6222 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
6223 ncx->blk_loop.iterix = cx->blk_loop.iterix;
6224 ncx->blk_loop.itermax = cx->blk_loop.itermax;
6227 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
6228 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
6229 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
6230 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6243 Perl_si_dup(pTHX_ PERL_SI *si)
6248 return (PERL_SI*)NULL;
6250 /* look for it in the table first */
6251 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6255 /* create anew and remember what it is */
6256 Newz(56, nsi, 1, PERL_SI);
6257 ptr_table_store(PL_ptr_table, si, nsi);
6259 nsi->si_stack = av_dup_inc(si->si_stack);
6260 nsi->si_cxix = si->si_cxix;
6261 nsi->si_cxmax = si->si_cxmax;
6262 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6263 nsi->si_type = si->si_type;
6264 nsi->si_prev = si_dup(si->si_prev);
6265 nsi->si_next = si_dup(si->si_next);
6266 nsi->si_markoff = si->si_markoff;
6271 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
6272 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
6273 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
6274 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
6275 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
6276 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
6277 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
6278 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
6279 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
6280 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
6281 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
6282 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
6285 #define pv_dup_inc(p) SAVEPV(p)
6286 #define pv_dup(p) SAVEPV(p)
6287 #define svp_dup_inc(p,pp) any_dup(p,pp)
6290 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
6297 /* look for it in the table first */
6298 ret = ptr_table_fetch(PL_ptr_table, v);
6302 /* see if it is part of the interpreter structure */
6303 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
6304 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
6312 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
6314 ANY *ss = proto_perl->Tsavestack;
6315 I32 ix = proto_perl->Tsavestack_ix;
6316 I32 max = proto_perl->Tsavestack_max;
6329 void (*dptr) (void*);
6330 void (*dxptr) (pTHXo_ void*);
6332 Newz(54, nss, max, ANY);
6338 case SAVEt_ITEM: /* normal string */
6339 sv = (SV*)POPPTR(ss,ix);
6340 TOPPTR(nss,ix) = sv_dup_inc(sv);
6341 sv = (SV*)POPPTR(ss,ix);
6342 TOPPTR(nss,ix) = sv_dup_inc(sv);
6344 case SAVEt_SV: /* scalar reference */
6345 sv = (SV*)POPPTR(ss,ix);
6346 TOPPTR(nss,ix) = sv_dup_inc(sv);
6347 gv = (GV*)POPPTR(ss,ix);
6348 TOPPTR(nss,ix) = gv_dup_inc(gv);
6350 case SAVEt_GENERIC_SVREF: /* generic sv */
6351 case SAVEt_SVREF: /* scalar reference */
6352 sv = (SV*)POPPTR(ss,ix);
6353 TOPPTR(nss,ix) = sv_dup_inc(sv);
6354 ptr = POPPTR(ss,ix);
6355 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
6357 case SAVEt_AV: /* array reference */
6358 av = (AV*)POPPTR(ss,ix);
6359 TOPPTR(nss,ix) = av_dup_inc(av);
6360 gv = (GV*)POPPTR(ss,ix);
6361 TOPPTR(nss,ix) = gv_dup(gv);
6363 case SAVEt_HV: /* hash reference */
6364 hv = (HV*)POPPTR(ss,ix);
6365 TOPPTR(nss,ix) = hv_dup_inc(hv);
6366 gv = (GV*)POPPTR(ss,ix);
6367 TOPPTR(nss,ix) = gv_dup(gv);
6369 case SAVEt_INT: /* int reference */
6370 ptr = POPPTR(ss,ix);
6371 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6372 intval = (int)POPINT(ss,ix);
6373 TOPINT(nss,ix) = intval;
6375 case SAVEt_LONG: /* long reference */
6376 ptr = POPPTR(ss,ix);
6377 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6378 longval = (long)POPLONG(ss,ix);
6379 TOPLONG(nss,ix) = longval;
6381 case SAVEt_I32: /* I32 reference */
6382 case SAVEt_I16: /* I16 reference */
6383 case SAVEt_I8: /* I8 reference */
6384 ptr = POPPTR(ss,ix);
6385 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6389 case SAVEt_IV: /* IV reference */
6390 ptr = POPPTR(ss,ix);
6391 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6395 case SAVEt_SPTR: /* SV* reference */
6396 ptr = POPPTR(ss,ix);
6397 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6398 sv = (SV*)POPPTR(ss,ix);
6399 TOPPTR(nss,ix) = sv_dup(sv);
6401 case SAVEt_VPTR: /* random* reference */
6402 ptr = POPPTR(ss,ix);
6403 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6404 ptr = POPPTR(ss,ix);
6405 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6407 case SAVEt_PPTR: /* char* reference */
6408 ptr = POPPTR(ss,ix);
6409 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6410 c = (char*)POPPTR(ss,ix);
6411 TOPPTR(nss,ix) = pv_dup(c);
6413 case SAVEt_HPTR: /* HV* reference */
6414 ptr = POPPTR(ss,ix);
6415 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6416 hv = (HV*)POPPTR(ss,ix);
6417 TOPPTR(nss,ix) = hv_dup(hv);
6419 case SAVEt_APTR: /* AV* reference */
6420 ptr = POPPTR(ss,ix);
6421 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6422 av = (AV*)POPPTR(ss,ix);
6423 TOPPTR(nss,ix) = av_dup(av);
6426 gv = (GV*)POPPTR(ss,ix);
6427 TOPPTR(nss,ix) = gv_dup(gv);
6429 case SAVEt_GP: /* scalar reference */
6430 gp = (GP*)POPPTR(ss,ix);
6431 TOPPTR(nss,ix) = gp = gp_dup(gp);
6432 (void)GpREFCNT_inc(gp);
6433 gv = (GV*)POPPTR(ss,ix);
6434 TOPPTR(nss,ix) = gv_dup_inc(c);
6435 c = (char*)POPPTR(ss,ix);
6436 TOPPTR(nss,ix) = pv_dup(c);
6443 sv = (SV*)POPPTR(ss,ix);
6444 TOPPTR(nss,ix) = sv_dup_inc(sv);
6447 ptr = POPPTR(ss,ix);
6448 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
6449 /* these are assumed to be refcounted properly */
6450 switch (((OP*)ptr)->op_type) {
6457 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6460 TOPPTR(nss,ix) = Nullop;
6465 TOPPTR(nss,ix) = Nullop;
6468 c = (char*)POPPTR(ss,ix);
6469 TOPPTR(nss,ix) = pv_dup_inc(c);
6472 longval = POPLONG(ss,ix);
6473 TOPLONG(nss,ix) = longval;
6476 hv = (HV*)POPPTR(ss,ix);
6477 TOPPTR(nss,ix) = hv_dup_inc(hv);
6478 c = (char*)POPPTR(ss,ix);
6479 TOPPTR(nss,ix) = pv_dup_inc(c);
6483 case SAVEt_DESTRUCTOR:
6484 ptr = POPPTR(ss,ix);
6485 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
6486 dptr = POPDPTR(ss,ix);
6487 TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
6489 case SAVEt_DESTRUCTOR_X:
6490 ptr = POPPTR(ss,ix);
6491 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
6492 dxptr = POPDXPTR(ss,ix);
6493 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
6495 case SAVEt_REGCONTEXT:
6501 case SAVEt_STACK_POS: /* Position on Perl stack */
6505 case SAVEt_AELEM: /* array element */
6506 sv = (SV*)POPPTR(ss,ix);
6507 TOPPTR(nss,ix) = sv_dup_inc(sv);
6510 av = (AV*)POPPTR(ss,ix);
6511 TOPPTR(nss,ix) = av_dup_inc(av);
6513 case SAVEt_HELEM: /* hash element */
6514 sv = (SV*)POPPTR(ss,ix);
6515 TOPPTR(nss,ix) = sv_dup_inc(sv);
6516 sv = (SV*)POPPTR(ss,ix);
6517 TOPPTR(nss,ix) = sv_dup_inc(sv);
6518 hv = (HV*)POPPTR(ss,ix);
6519 TOPPTR(nss,ix) = hv_dup_inc(hv);
6522 ptr = POPPTR(ss,ix);
6523 TOPPTR(nss,ix) = ptr;
6530 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
6542 perl_clone(PerlInterpreter *proto_perl, UV flags)
6545 CPerlObj *pPerl = (CPerlObj*)proto_perl;
6548 #ifdef PERL_IMPLICIT_SYS
6549 return perl_clone_using(proto_perl, flags,
6551 proto_perl->IMemShared,
6552 proto_perl->IMemParse,
6562 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
6563 struct IPerlMem* ipM, struct IPerlMem* ipMS,
6564 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
6565 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
6566 struct IPerlDir* ipD, struct IPerlSock* ipS,
6567 struct IPerlProc* ipP)
6569 /* XXX many of the string copies here can be optimized if they're
6570 * constants; they need to be allocated as common memory and just
6571 * their pointers copied. */
6577 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
6579 PERL_SET_INTERP(pPerl);
6580 # else /* !PERL_OBJECT */
6581 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
6582 PERL_SET_INTERP(my_perl);
6585 memset(my_perl, 0xab, sizeof(PerlInterpreter));
6590 # else /* !DEBUGGING */
6591 Zero(my_perl, 1, PerlInterpreter);
6592 # endif /* DEBUGGING */
6596 PL_MemShared = ipMS;
6604 # endif /* PERL_OBJECT */
6605 #else /* !PERL_IMPLICIT_SYS */
6609 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
6610 PERL_SET_INTERP(my_perl);
6613 memset(my_perl, 0xab, sizeof(PerlInterpreter));
6618 # else /* !DEBUGGING */
6619 Zero(my_perl, 1, PerlInterpreter);
6620 # endif /* DEBUGGING */
6621 #endif /* PERL_IMPLICIT_SYS */
6624 PL_xiv_arenaroot = NULL;
6629 PL_xpviv_root = NULL;
6630 PL_xpvnv_root = NULL;
6631 PL_xpvcv_root = NULL;
6632 PL_xpvav_root = NULL;
6633 PL_xpvhv_root = NULL;
6634 PL_xpvmg_root = NULL;
6635 PL_xpvlv_root = NULL;
6636 PL_xpvbm_root = NULL;
6638 PL_nice_chunk = NULL;
6639 PL_nice_chunk_size = 0;
6642 PL_sv_root = Nullsv;
6643 PL_sv_arenaroot = Nullsv;
6645 PL_debug = proto_perl->Idebug;
6647 /* create SV map for pointer relocation */
6648 PL_ptr_table = ptr_table_new();
6650 /* initialize these special pointers as early as possible */
6651 SvANY(&PL_sv_undef) = NULL;
6652 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
6653 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
6654 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
6657 SvUPGRADE(&PL_sv_no, SVt_PVNV);
6659 SvANY(&PL_sv_no) = new_XPVNV();
6661 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
6662 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6663 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
6664 SvCUR(&PL_sv_no) = 0;
6665 SvLEN(&PL_sv_no) = 1;
6666 SvNVX(&PL_sv_no) = 0;
6667 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
6670 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
6672 SvANY(&PL_sv_yes) = new_XPVNV();
6674 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
6675 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
6676 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
6677 SvCUR(&PL_sv_yes) = 1;
6678 SvLEN(&PL_sv_yes) = 2;
6679 SvNVX(&PL_sv_yes) = 1;
6680 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
6682 /* create shared string table */
6683 PL_strtab = newHV();
6684 HvSHAREKEYS_off(PL_strtab);
6685 hv_ksplit(PL_strtab, 512);
6686 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
6688 PL_compiling = proto_perl->Icompiling;
6689 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
6690 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
6691 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
6692 if (!specialWARN(PL_compiling.cop_warnings))
6693 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
6694 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
6696 /* pseudo environmental stuff */
6697 PL_origargc = proto_perl->Iorigargc;
6699 New(0, PL_origargv, i+1, char*);
6700 PL_origargv[i] = '\0';
6702 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
6704 PL_envgv = gv_dup(proto_perl->Ienvgv);
6705 PL_incgv = gv_dup(proto_perl->Iincgv);
6706 PL_hintgv = gv_dup(proto_perl->Ihintgv);
6707 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
6708 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
6709 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
6712 PL_minus_c = proto_perl->Iminus_c;
6713 Copy(proto_perl->Ipatchlevel, PL_patchlevel, 10, char);
6714 PL_localpatches = proto_perl->Ilocalpatches;
6715 PL_splitstr = proto_perl->Isplitstr;
6716 PL_preprocess = proto_perl->Ipreprocess;
6717 PL_minus_n = proto_perl->Iminus_n;
6718 PL_minus_p = proto_perl->Iminus_p;
6719 PL_minus_l = proto_perl->Iminus_l;
6720 PL_minus_a = proto_perl->Iminus_a;
6721 PL_minus_F = proto_perl->Iminus_F;
6722 PL_doswitches = proto_perl->Idoswitches;
6723 PL_dowarn = proto_perl->Idowarn;
6724 PL_doextract = proto_perl->Idoextract;
6725 PL_sawampersand = proto_perl->Isawampersand;
6726 PL_unsafe = proto_perl->Iunsafe;
6727 PL_inplace = SAVEPV(proto_perl->Iinplace);
6728 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
6729 PL_perldb = proto_perl->Iperldb;
6730 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
6732 /* magical thingies */
6733 /* XXX time(&PL_basetime) when asked for? */
6734 PL_basetime = proto_perl->Ibasetime;
6735 PL_formfeed = sv_dup(proto_perl->Iformfeed);
6737 PL_maxsysfd = proto_perl->Imaxsysfd;
6738 PL_multiline = proto_perl->Imultiline;
6739 PL_statusvalue = proto_perl->Istatusvalue;
6741 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
6744 /* shortcuts to various I/O objects */
6745 PL_stdingv = gv_dup(proto_perl->Istdingv);
6746 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
6747 PL_defgv = gv_dup(proto_perl->Idefgv);
6748 PL_argvgv = gv_dup(proto_perl->Iargvgv);
6749 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
6750 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
6752 /* shortcuts to regexp stuff */
6753 PL_replgv = gv_dup(proto_perl->Ireplgv);
6755 /* shortcuts to misc objects */
6756 PL_errgv = gv_dup(proto_perl->Ierrgv);
6758 /* shortcuts to debugging objects */
6759 PL_DBgv = gv_dup(proto_perl->IDBgv);
6760 PL_DBline = gv_dup(proto_perl->IDBline);
6761 PL_DBsub = gv_dup(proto_perl->IDBsub);
6762 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
6763 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
6764 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
6765 PL_lineary = av_dup(proto_perl->Ilineary);
6766 PL_dbargs = av_dup(proto_perl->Idbargs);
6769 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
6770 PL_curstash = hv_dup(proto_perl->Tcurstash);
6771 PL_debstash = hv_dup(proto_perl->Idebstash);
6772 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
6773 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
6775 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
6776 PL_endav = av_dup_inc(proto_perl->Iendav);
6777 PL_stopav = av_dup_inc(proto_perl->Istopav);
6778 PL_initav = av_dup_inc(proto_perl->Iinitav);
6780 PL_sub_generation = proto_perl->Isub_generation;
6782 /* funky return mechanisms */
6783 PL_forkprocess = proto_perl->Iforkprocess;
6785 /* subprocess state */
6786 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
6788 /* internal state */
6789 PL_tainting = proto_perl->Itainting;
6790 PL_maxo = proto_perl->Imaxo;
6791 if (proto_perl->Iop_mask)
6792 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
6794 PL_op_mask = Nullch;
6796 /* current interpreter roots */
6797 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
6798 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
6799 PL_main_start = proto_perl->Imain_start;
6800 PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root);
6801 PL_eval_start = proto_perl->Ieval_start;
6803 /* runtime control stuff */
6804 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
6805 PL_copline = proto_perl->Icopline;
6807 PL_filemode = proto_perl->Ifilemode;
6808 PL_lastfd = proto_perl->Ilastfd;
6809 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
6812 PL_gensym = proto_perl->Igensym;
6813 PL_preambled = proto_perl->Ipreambled;
6814 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
6815 PL_laststatval = proto_perl->Ilaststatval;
6816 PL_laststype = proto_perl->Ilaststype;
6817 PL_mess_sv = Nullsv;
6819 PL_orslen = proto_perl->Iorslen;
6820 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
6821 PL_ofmt = SAVEPV(proto_perl->Iofmt);
6823 /* interpreter atexit processing */
6824 PL_exitlistlen = proto_perl->Iexitlistlen;
6825 if (PL_exitlistlen) {
6826 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6827 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
6830 PL_exitlist = (PerlExitListEntry*)NULL;
6831 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
6833 PL_profiledata = NULL;
6834 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
6835 /* PL_rsfp_filters entries have fake IoDIRP() */
6836 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
6838 PL_compcv = cv_dup(proto_perl->Icompcv);
6839 PL_comppad = av_dup(proto_perl->Icomppad);
6840 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
6841 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
6842 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
6843 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
6844 proto_perl->Tcurpad);
6846 #ifdef HAVE_INTERP_INTERN
6847 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
6850 /* more statics moved here */
6851 PL_generation = proto_perl->Igeneration;
6852 PL_DBcv = cv_dup(proto_perl->IDBcv);
6853 PL_archpat_auto = SAVEPV(proto_perl->Iarchpat_auto);
6855 PL_in_clean_objs = proto_perl->Iin_clean_objs;
6856 PL_in_clean_all = proto_perl->Iin_clean_all;
6858 PL_uid = proto_perl->Iuid;
6859 PL_euid = proto_perl->Ieuid;
6860 PL_gid = proto_perl->Igid;
6861 PL_egid = proto_perl->Iegid;
6862 PL_nomemok = proto_perl->Inomemok;
6863 PL_an = proto_perl->Ian;
6864 PL_cop_seqmax = proto_perl->Icop_seqmax;
6865 PL_op_seqmax = proto_perl->Iop_seqmax;
6866 PL_evalseq = proto_perl->Ievalseq;
6867 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
6868 PL_origalen = proto_perl->Iorigalen;
6869 PL_pidstatus = newHV(); /* XXX flag for cloning? */
6870 PL_osname = SAVEPV(proto_perl->Iosname);
6871 PL_sh_path = SAVEPV(proto_perl->Ish_path);
6872 PL_sighandlerp = proto_perl->Isighandlerp;
6875 PL_runops = proto_perl->Irunops;
6877 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
6880 PL_cshlen = proto_perl->Icshlen;
6881 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
6884 PL_lex_state = proto_perl->Ilex_state;
6885 PL_lex_defer = proto_perl->Ilex_defer;
6886 PL_lex_expect = proto_perl->Ilex_expect;
6887 PL_lex_formbrack = proto_perl->Ilex_formbrack;
6888 PL_lex_dojoin = proto_perl->Ilex_dojoin;
6889 PL_lex_starts = proto_perl->Ilex_starts;
6890 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
6891 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
6892 PL_lex_op = proto_perl->Ilex_op;
6893 PL_lex_inpat = proto_perl->Ilex_inpat;
6894 PL_lex_inwhat = proto_perl->Ilex_inwhat;
6895 PL_lex_brackets = proto_perl->Ilex_brackets;
6896 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
6897 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
6898 PL_lex_casemods = proto_perl->Ilex_casemods;
6899 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
6900 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
6902 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
6903 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
6904 PL_nexttoke = proto_perl->Inexttoke;
6906 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
6907 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
6908 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6909 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
6910 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6911 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
6912 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6913 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
6914 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
6915 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6916 PL_pending_ident = proto_perl->Ipending_ident;
6917 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
6919 PL_expect = proto_perl->Iexpect;
6921 PL_multi_start = proto_perl->Imulti_start;
6922 PL_multi_end = proto_perl->Imulti_end;
6923 PL_multi_open = proto_perl->Imulti_open;
6924 PL_multi_close = proto_perl->Imulti_close;
6926 PL_error_count = proto_perl->Ierror_count;
6927 PL_subline = proto_perl->Isubline;
6928 PL_subname = sv_dup_inc(proto_perl->Isubname);
6930 PL_min_intro_pending = proto_perl->Imin_intro_pending;
6931 PL_max_intro_pending = proto_perl->Imax_intro_pending;
6932 PL_padix = proto_perl->Ipadix;
6933 PL_padix_floor = proto_perl->Ipadix_floor;
6934 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
6936 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
6937 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6938 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
6939 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
6940 PL_last_lop_op = proto_perl->Ilast_lop_op;
6941 PL_in_my = proto_perl->Iin_my;
6942 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
6944 PL_cryptseen = proto_perl->Icryptseen;
6947 PL_hints = proto_perl->Ihints;
6949 PL_amagic_generation = proto_perl->Iamagic_generation;
6951 #ifdef USE_LOCALE_COLLATE
6952 PL_collation_ix = proto_perl->Icollation_ix;
6953 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
6954 PL_collation_standard = proto_perl->Icollation_standard;
6955 PL_collxfrm_base = proto_perl->Icollxfrm_base;
6956 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
6957 #endif /* USE_LOCALE_COLLATE */
6959 #ifdef USE_LOCALE_NUMERIC
6960 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
6961 PL_numeric_standard = proto_perl->Inumeric_standard;
6962 PL_numeric_local = proto_perl->Inumeric_local;
6963 PL_numeric_radix = proto_perl->Inumeric_radix;
6964 #endif /* !USE_LOCALE_NUMERIC */
6966 /* utf8 character classes */
6967 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
6968 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
6969 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
6970 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
6971 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
6972 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
6973 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
6974 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
6975 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
6976 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
6977 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
6978 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
6979 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
6980 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
6981 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
6982 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
6983 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
6986 PL_last_swash_hv = Nullhv; /* reinits on demand */
6987 PL_last_swash_klen = 0;
6988 PL_last_swash_key[0]= '\0';
6989 PL_last_swash_tmps = (U8*)NULL;
6990 PL_last_swash_slen = 0;
6992 /* perly.c globals */
6993 PL_yydebug = proto_perl->Iyydebug;
6994 PL_yynerrs = proto_perl->Iyynerrs;
6995 PL_yyerrflag = proto_perl->Iyyerrflag;
6996 PL_yychar = proto_perl->Iyychar;
6997 PL_yyval = proto_perl->Iyyval;
6998 PL_yylval = proto_perl->Iyylval;
7000 PL_glob_index = proto_perl->Iglob_index;
7001 PL_srand_called = proto_perl->Isrand_called;
7002 PL_uudmap['M'] = 0; /* reinits on demand */
7003 PL_bitcount = Nullch; /* reinits on demand */
7005 if (proto_perl->Ipsig_ptr) {
7006 int sig_num[] = { SIG_NUM };
7007 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7008 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7009 for (i = 1; PL_sig_name[i]; i++) {
7010 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7011 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7015 PL_psig_ptr = (SV**)NULL;
7016 PL_psig_name = (SV**)NULL;
7019 /* thrdvar.h stuff */
7022 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7023 PL_tmps_ix = proto_perl->Ttmps_ix;
7024 PL_tmps_max = proto_perl->Ttmps_max;
7025 PL_tmps_floor = proto_perl->Ttmps_floor;
7026 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7028 while (i <= PL_tmps_ix) {
7029 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7033 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7034 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7035 Newz(54, PL_markstack, i, I32);
7036 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7037 - proto_perl->Tmarkstack);
7038 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7039 - proto_perl->Tmarkstack);
7040 Copy(proto_perl->Tmarkstack, PL_markstack,
7041 PL_markstack_ptr - PL_markstack + 1, I32);
7043 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7044 * NOTE: unlike the others! */
7045 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7046 PL_scopestack_max = proto_perl->Tscopestack_max;
7047 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7048 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7050 /* next push_return() sets PL_retstack[PL_retstack_ix]
7051 * NOTE: unlike the others! */
7052 PL_retstack_ix = proto_perl->Tretstack_ix;
7053 PL_retstack_max = proto_perl->Tretstack_max;
7054 Newz(54, PL_retstack, PL_retstack_max, OP*);
7055 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7057 /* NOTE: si_dup() looks at PL_markstack */
7058 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7060 /* PL_curstack = PL_curstackinfo->si_stack; */
7061 PL_curstack = av_dup(proto_perl->Tcurstack);
7062 PL_mainstack = av_dup(proto_perl->Tmainstack);
7064 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7065 PL_stack_base = AvARRAY(PL_curstack);
7066 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7067 - proto_perl->Tstack_base);
7068 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7070 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7071 * NOTE: unlike the others! */
7072 PL_savestack_ix = proto_perl->Tsavestack_ix;
7073 PL_savestack_max = proto_perl->Tsavestack_max;
7074 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7075 PL_savestack = ss_dup(proto_perl);
7081 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7082 PL_top_env = &PL_start_env;
7084 PL_op = proto_perl->Top;
7087 PL_Xpv = (XPV*)NULL;
7088 PL_na = proto_perl->Tna;
7090 PL_statbuf = proto_perl->Tstatbuf;
7091 PL_statcache = proto_perl->Tstatcache;
7092 PL_statgv = gv_dup(proto_perl->Tstatgv);
7093 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7095 PL_timesbuf = proto_perl->Ttimesbuf;
7098 PL_tainted = proto_perl->Ttainted;
7099 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7100 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7101 PL_rs = sv_dup_inc(proto_perl->Trs);
7102 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7103 PL_ofslen = proto_perl->Tofslen;
7104 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7105 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7106 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7107 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7108 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7109 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7111 PL_restartop = proto_perl->Trestartop;
7112 PL_in_eval = proto_perl->Tin_eval;
7113 PL_delaymagic = proto_perl->Tdelaymagic;
7114 PL_dirty = proto_perl->Tdirty;
7115 PL_localizing = proto_perl->Tlocalizing;
7117 PL_protect = proto_perl->Tprotect;
7118 PL_errors = sv_dup_inc(proto_perl->Terrors);
7119 PL_av_fetch_sv = Nullsv;
7120 PL_hv_fetch_sv = Nullsv;
7121 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7122 PL_modcount = proto_perl->Tmodcount;
7123 PL_lastgotoprobe = Nullop;
7124 PL_dumpindent = proto_perl->Tdumpindent;
7126 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7127 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7128 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7129 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7130 PL_sortcxix = proto_perl->Tsortcxix;
7131 PL_efloatbuf = Nullch; /* reinits on demand */
7132 PL_efloatsize = 0; /* reinits on demand */
7136 PL_screamfirst = NULL;
7137 PL_screamnext = NULL;
7138 PL_maxscream = -1; /* reinits on demand */
7139 PL_lastscream = Nullsv;
7141 PL_watchaddr = NULL;
7142 PL_watchok = Nullch;
7144 PL_regdummy = proto_perl->Tregdummy;
7145 PL_regcomp_parse = Nullch;
7146 PL_regxend = Nullch;
7147 PL_regcode = (regnode*)NULL;
7150 PL_regprecomp = Nullch;
7155 PL_seen_zerolen = 0;
7157 PL_regcomp_rx = (regexp*)NULL;
7159 PL_colorset = 0; /* reinits PL_colors[] */
7160 /*PL_colors[6] = {0,0,0,0,0,0};*/
7161 PL_reg_whilem_seen = 0;
7162 PL_reginput = Nullch;
7165 PL_regstartp = (I32*)NULL;
7166 PL_regendp = (I32*)NULL;
7167 PL_reglastparen = (U32*)NULL;
7168 PL_regtill = Nullch;
7170 PL_reg_start_tmp = (char**)NULL;
7171 PL_reg_start_tmpl = 0;
7172 PL_regdata = (struct reg_data*)NULL;
7175 PL_reg_eval_set = 0;
7177 PL_regprogram = (regnode*)NULL;
7179 PL_regcc = (CURCUR*)NULL;
7180 PL_reg_call_cc = (struct re_cc_state*)NULL;
7181 PL_reg_re = (regexp*)NULL;
7182 PL_reg_ganch = Nullch;
7184 PL_reg_magic = (MAGIC*)NULL;
7186 PL_reg_oldcurpm = (PMOP*)NULL;
7187 PL_reg_curpm = (PMOP*)NULL;
7188 PL_reg_oldsaved = Nullch;
7189 PL_reg_oldsavedlen = 0;
7191 PL_reg_leftiter = 0;
7192 PL_reg_poscache = Nullch;
7193 PL_reg_poscache_size= 0;
7195 /* RE engine - function pointers */
7196 PL_regcompp = proto_perl->Tregcompp;
7197 PL_regexecp = proto_perl->Tregexecp;
7198 PL_regint_start = proto_perl->Tregint_start;
7199 PL_regint_string = proto_perl->Tregint_string;
7200 PL_regfree = proto_perl->Tregfree;
7202 PL_reginterp_cnt = 0;
7203 PL_reg_starttry = 0;
7206 return (PerlInterpreter*)pPerl;
7212 #else /* !USE_ITHREADS */
7218 #endif /* USE_ITHREADS */
7221 do_report_used(pTHXo_ SV *sv)
7223 if (SvTYPE(sv) != SVTYPEMASK) {
7224 PerlIO_printf(Perl_debug_log, "****\n");
7230 do_clean_objs(pTHXo_ SV *sv)
7234 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7235 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7241 /* XXX Might want to check arrays, etc. */
7244 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7246 do_clean_named_objs(pTHXo_ SV *sv)
7248 if (SvTYPE(sv) == SVt_PVGV) {
7249 if ( SvOBJECT(GvSV(sv)) ||
7250 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7251 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7252 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7253 GvCV(sv) && SvOBJECT(GvCV(sv)) )
7255 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
7263 do_clean_all(pTHXo_ SV *sv)
7265 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
7266 SvFLAGS(sv) |= SVf_BREAK;