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 =for apidoc sv_upgrade
927 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
934 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
944 if (SvTYPE(sv) == mt)
950 switch (SvTYPE(sv)) {
971 else if (mt < SVt_PVIV)
988 pv = (char*)SvRV(sv);
1008 else if (mt == SVt_NV)
1019 del_XPVIV(SvANY(sv));
1029 del_XPVNV(SvANY(sv));
1037 magic = SvMAGIC(sv);
1038 stash = SvSTASH(sv);
1039 del_XPVMG(SvANY(sv));
1042 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1047 Perl_croak(aTHX_ "Can't upgrade to undef");
1049 SvANY(sv) = new_XIV();
1053 SvANY(sv) = new_XNV();
1057 SvANY(sv) = new_XRV();
1061 SvANY(sv) = new_XPV();
1067 SvANY(sv) = new_XPVIV();
1077 SvANY(sv) = new_XPVNV();
1085 SvANY(sv) = new_XPVMG();
1091 SvMAGIC(sv) = magic;
1092 SvSTASH(sv) = stash;
1095 SvANY(sv) = new_XPVLV();
1101 SvMAGIC(sv) = magic;
1102 SvSTASH(sv) = stash;
1109 SvANY(sv) = new_XPVAV();
1117 SvMAGIC(sv) = magic;
1118 SvSTASH(sv) = stash;
1124 SvANY(sv) = new_XPVHV();
1132 SvMAGIC(sv) = magic;
1133 SvSTASH(sv) = stash;
1140 SvANY(sv) = new_XPVCV();
1141 Zero(SvANY(sv), 1, XPVCV);
1147 SvMAGIC(sv) = magic;
1148 SvSTASH(sv) = stash;
1151 SvANY(sv) = new_XPVGV();
1157 SvMAGIC(sv) = magic;
1158 SvSTASH(sv) = stash;
1166 SvANY(sv) = new_XPVBM();
1172 SvMAGIC(sv) = magic;
1173 SvSTASH(sv) = stash;
1179 SvANY(sv) = new_XPVFM();
1180 Zero(SvANY(sv), 1, XPVFM);
1186 SvMAGIC(sv) = magic;
1187 SvSTASH(sv) = stash;
1190 SvANY(sv) = new_XPVIO();
1191 Zero(SvANY(sv), 1, XPVIO);
1197 SvMAGIC(sv) = magic;
1198 SvSTASH(sv) = stash;
1199 IoPAGE_LEN(sv) = 60;
1202 SvFLAGS(sv) &= ~SVTYPEMASK;
1208 Perl_sv_backoff(pTHX_ register SV *sv)
1212 char *s = SvPVX(sv);
1213 SvLEN(sv) += SvIVX(sv);
1214 SvPVX(sv) -= SvIVX(sv);
1216 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1218 SvFLAGS(sv) &= ~SVf_OOK;
1225 Expands the character buffer in the SV. This will use C<sv_unref> and will
1226 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1233 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1237 #ifdef HAS_64K_LIMIT
1238 if (newlen >= 0x10000) {
1239 PerlIO_printf(Perl_debug_log,
1240 "Allocation too large: %"UVxf"\n", (UV)newlen);
1243 #endif /* HAS_64K_LIMIT */
1246 if (SvTYPE(sv) < SVt_PV) {
1247 sv_upgrade(sv, SVt_PV);
1250 else if (SvOOK(sv)) { /* pv is offset? */
1253 if (newlen > SvLEN(sv))
1254 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1255 #ifdef HAS_64K_LIMIT
1256 if (newlen >= 0x10000)
1262 if (newlen > SvLEN(sv)) { /* need more room? */
1263 if (SvLEN(sv) && s) {
1264 #if defined(MYMALLOC) && !defined(PURIFY) && !defined(LEAKTEST)
1265 STRLEN l = malloced_size((void*)SvPVX(sv));
1271 Renew(s,newlen,char);
1274 New(703,s,newlen,char);
1276 SvLEN_set(sv, newlen);
1282 =for apidoc sv_setiv
1284 Copies an integer into the given SV. Does not handle 'set' magic. See
1291 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1293 SV_CHECK_THINKFIRST(sv);
1294 switch (SvTYPE(sv)) {
1296 sv_upgrade(sv, SVt_IV);
1299 sv_upgrade(sv, SVt_PVNV);
1303 sv_upgrade(sv, SVt_PVIV);
1314 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1315 PL_op_desc[PL_op->op_type]);
1318 (void)SvIOK_only(sv); /* validate number */
1324 =for apidoc sv_setiv_mg
1326 Like C<sv_setiv>, but also handles 'set' magic.
1332 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1339 =for apidoc sv_setuv
1341 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1348 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1356 =for apidoc sv_setuv_mg
1358 Like C<sv_setuv>, but also handles 'set' magic.
1364 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1371 =for apidoc sv_setnv
1373 Copies a double into the given SV. Does not handle 'set' magic. See
1380 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1382 SV_CHECK_THINKFIRST(sv);
1383 switch (SvTYPE(sv)) {
1386 sv_upgrade(sv, SVt_NV);
1391 sv_upgrade(sv, SVt_PVNV);
1402 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1403 PL_op_name[PL_op->op_type]);
1407 (void)SvNOK_only(sv); /* validate number */
1412 =for apidoc sv_setnv_mg
1414 Like C<sv_setnv>, but also handles 'set' magic.
1420 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1427 S_not_a_number(pTHX_ SV *sv)
1433 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1434 /* each *s can expand to 4 chars + "...\0",
1435 i.e. need room for 8 chars */
1437 for (s = SvPVX(sv); *s && d < limit; s++) {
1439 if (ch & 128 && !isPRINT_LC(ch)) {
1448 else if (ch == '\r') {
1452 else if (ch == '\f') {
1456 else if (ch == '\\') {
1460 else if (isPRINT_LC(ch))
1475 Perl_warner(aTHX_ WARN_NUMERIC,
1476 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1477 PL_op_desc[PL_op->op_type]);
1479 Perl_warner(aTHX_ WARN_NUMERIC,
1480 "Argument \"%s\" isn't numeric", tmpbuf);
1483 /* the number can be converted to integer with atol() or atoll() */
1484 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1485 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1486 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1487 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1489 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1490 until proven guilty, assume that things are not that bad... */
1493 Perl_sv_2iv(pTHX_ register SV *sv)
1497 if (SvGMAGICAL(sv)) {
1502 return I_V(SvNVX(sv));
1504 if (SvPOKp(sv) && SvLEN(sv))
1507 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1509 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1515 if (SvTHINKFIRST(sv)) {
1518 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1519 return SvIV(tmpstr);
1520 return PTR2IV(SvRV(sv));
1522 if (SvREADONLY(sv) && !SvOK(sv)) {
1524 if (ckWARN(WARN_UNINITIALIZED))
1531 return (IV)(SvUVX(sv));
1538 /* We can cache the IV/UV value even if it not good enough
1539 * to reconstruct NV, since the conversion to PV will prefer
1543 if (SvTYPE(sv) == SVt_NV)
1544 sv_upgrade(sv, SVt_PVNV);
1547 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1548 SvIVX(sv) = I_V(SvNVX(sv));
1550 SvUVX(sv) = U_V(SvNVX(sv));
1553 DEBUG_c(PerlIO_printf(Perl_debug_log,
1554 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1558 return (IV)SvUVX(sv);
1561 else if (SvPOKp(sv) && SvLEN(sv)) {
1562 I32 numtype = looks_like_number(sv);
1564 /* We want to avoid a possible problem when we cache an IV which
1565 may be later translated to an NV, and the resulting NV is not
1566 the translation of the initial data.
1568 This means that if we cache such an IV, we need to cache the
1569 NV as well. Moreover, we trade speed for space, and do not
1570 cache the NV if not needed.
1572 if (numtype & IS_NUMBER_NOT_IV) {
1573 /* May be not an integer. Need to cache NV if we cache IV
1574 * - otherwise future conversion to NV will be wrong. */
1577 d = Atof(SvPVX(sv));
1579 if (SvTYPE(sv) < SVt_PVNV)
1580 sv_upgrade(sv, SVt_PVNV);
1584 #if defined(USE_LONG_DOUBLE)
1585 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1586 PTR2UV(sv), SvNVX(sv)));
1588 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1589 PTR2UV(sv), SvNVX(sv)));
1591 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1592 SvIVX(sv) = I_V(SvNVX(sv));
1594 SvUVX(sv) = U_V(SvNVX(sv));
1600 /* The NV may be reconstructed from IV - safe to cache IV,
1601 which may be calculated by atol(). */
1602 if (SvTYPE(sv) == SVt_PV)
1603 sv_upgrade(sv, SVt_PVIV);
1605 SvIVX(sv) = Atol(SvPVX(sv));
1607 else { /* Not a number. Cache 0. */
1610 if (SvTYPE(sv) < SVt_PVIV)
1611 sv_upgrade(sv, SVt_PVIV);
1614 if (ckWARN(WARN_NUMERIC))
1620 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1622 if (SvTYPE(sv) < SVt_IV)
1623 /* Typically the caller expects that sv_any is not NULL now. */
1624 sv_upgrade(sv, SVt_IV);
1627 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1628 PTR2UV(sv),SvIVX(sv)));
1629 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1633 Perl_sv_2uv(pTHX_ register SV *sv)
1637 if (SvGMAGICAL(sv)) {
1642 return U_V(SvNVX(sv));
1643 if (SvPOKp(sv) && SvLEN(sv))
1646 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1648 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1654 if (SvTHINKFIRST(sv)) {
1657 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1658 return SvUV(tmpstr);
1659 return PTR2UV(SvRV(sv));
1661 if (SvREADONLY(sv) && !SvOK(sv)) {
1663 if (ckWARN(WARN_UNINITIALIZED))
1673 return (UV)SvIVX(sv);
1677 /* We can cache the IV/UV value even if it not good enough
1678 * to reconstruct NV, since the conversion to PV will prefer
1681 if (SvTYPE(sv) == SVt_NV)
1682 sv_upgrade(sv, SVt_PVNV);
1684 if (SvNVX(sv) >= -0.5) {
1686 SvUVX(sv) = U_V(SvNVX(sv));
1689 SvIVX(sv) = I_V(SvNVX(sv));
1691 DEBUG_c(PerlIO_printf(Perl_debug_log,
1692 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1695 (IV)(UV)SvIVX(sv)));
1696 return (UV)SvIVX(sv);
1699 else if (SvPOKp(sv) && SvLEN(sv)) {
1700 I32 numtype = looks_like_number(sv);
1702 /* We want to avoid a possible problem when we cache a UV which
1703 may be later translated to an NV, and the resulting NV is not
1704 the translation of the initial data.
1706 This means that if we cache such a UV, we need to cache the
1707 NV as well. Moreover, we trade speed for space, and do not
1708 cache the NV if not needed.
1710 if (numtype & IS_NUMBER_NOT_IV) {
1711 /* May be not an integer. Need to cache NV if we cache IV
1712 * - otherwise future conversion to NV will be wrong. */
1715 d = Atof(SvPVX(sv));
1717 if (SvTYPE(sv) < SVt_PVNV)
1718 sv_upgrade(sv, SVt_PVNV);
1722 #if defined(USE_LONG_DOUBLE)
1723 DEBUG_c(PerlIO_printf(Perl_debug_log,
1724 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1725 PTR2UV(sv), SvNVX(sv)));
1727 DEBUG_c(PerlIO_printf(Perl_debug_log,
1728 "0x%"UVxf" 2nv(%g)\n",
1729 PTR2UV(sv), SvNVX(sv)));
1731 if (SvNVX(sv) < -0.5) {
1732 SvIVX(sv) = I_V(SvNVX(sv));
1735 SvUVX(sv) = U_V(SvNVX(sv));
1739 else if (numtype & IS_NUMBER_NEG) {
1740 /* The NV may be reconstructed from IV - safe to cache IV,
1741 which may be calculated by atol(). */
1742 if (SvTYPE(sv) == SVt_PV)
1743 sv_upgrade(sv, SVt_PVIV);
1745 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1747 else if (numtype) { /* Non-negative */
1748 /* The NV may be reconstructed from UV - safe to cache UV,
1749 which may be calculated by strtoul()/atol. */
1750 if (SvTYPE(sv) == SVt_PV)
1751 sv_upgrade(sv, SVt_PVIV);
1753 (void)SvIsUV_on(sv);
1755 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1756 #else /* no atou(), but we know the number fits into IV... */
1757 /* The only problem may be if it is negative... */
1758 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1761 else { /* Not a number. Cache 0. */
1764 if (SvTYPE(sv) < SVt_PVIV)
1765 sv_upgrade(sv, SVt_PVIV);
1766 SvUVX(sv) = 0; /* We assume that 0s have the
1767 same bitmap in IV and UV. */
1769 (void)SvIsUV_on(sv);
1770 if (ckWARN(WARN_NUMERIC))
1775 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1777 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1780 if (SvTYPE(sv) < SVt_IV)
1781 /* Typically the caller expects that sv_any is not NULL now. */
1782 sv_upgrade(sv, SVt_IV);
1786 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1787 PTR2UV(sv),SvUVX(sv)));
1788 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1792 Perl_sv_2nv(pTHX_ register SV *sv)
1796 if (SvGMAGICAL(sv)) {
1800 if (SvPOKp(sv) && SvLEN(sv)) {
1802 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1804 return Atof(SvPVX(sv));
1808 return (NV)SvUVX(sv);
1810 return (NV)SvIVX(sv);
1813 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1815 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1821 if (SvTHINKFIRST(sv)) {
1824 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1825 return SvNV(tmpstr);
1826 return PTR2NV(SvRV(sv));
1828 if (SvREADONLY(sv) && !SvOK(sv)) {
1830 if (ckWARN(WARN_UNINITIALIZED))
1835 if (SvTYPE(sv) < SVt_NV) {
1836 if (SvTYPE(sv) == SVt_IV)
1837 sv_upgrade(sv, SVt_PVNV);
1839 sv_upgrade(sv, SVt_NV);
1840 #if defined(USE_LONG_DOUBLE)
1842 RESTORE_NUMERIC_STANDARD();
1843 PerlIO_printf(Perl_debug_log,
1844 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1845 PTR2UV(sv), SvNVX(sv));
1846 RESTORE_NUMERIC_LOCAL();
1850 RESTORE_NUMERIC_STANDARD();
1851 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1852 PTR2UV(sv), SvNVX(sv));
1853 RESTORE_NUMERIC_LOCAL();
1857 else if (SvTYPE(sv) < SVt_PVNV)
1858 sv_upgrade(sv, SVt_PVNV);
1860 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1862 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1864 else if (SvPOKp(sv) && SvLEN(sv)) {
1866 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1868 SvNVX(sv) = Atof(SvPVX(sv));
1872 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1874 if (SvTYPE(sv) < SVt_NV)
1875 /* Typically the caller expects that sv_any is not NULL now. */
1876 sv_upgrade(sv, SVt_NV);
1880 #if defined(USE_LONG_DOUBLE)
1882 RESTORE_NUMERIC_STANDARD();
1883 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1884 PTR2UV(sv), SvNVX(sv));
1885 RESTORE_NUMERIC_LOCAL();
1889 RESTORE_NUMERIC_STANDARD();
1890 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1891 PTR2UV(sv), SvNVX(sv));
1892 RESTORE_NUMERIC_LOCAL();
1899 S_asIV(pTHX_ SV *sv)
1901 I32 numtype = looks_like_number(sv);
1904 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1905 return Atol(SvPVX(sv));
1908 if (ckWARN(WARN_NUMERIC))
1911 d = Atof(SvPVX(sv));
1916 S_asUV(pTHX_ SV *sv)
1918 I32 numtype = looks_like_number(sv);
1921 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1922 return Strtoul(SvPVX(sv), Null(char**), 10);
1926 if (ckWARN(WARN_NUMERIC))
1929 return U_V(Atof(SvPVX(sv)));
1933 * Returns a combination of (advisory only - can get false negatives)
1934 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1936 * 0 if does not look like number.
1938 * In fact possible values are 0 and
1939 * IS_NUMBER_TO_INT_BY_ATOL 123
1940 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1941 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1942 * with a possible addition of IS_NUMBER_NEG.
1946 =for apidoc looks_like_number
1948 Test if an the content of an SV looks like a number (or is a
1955 Perl_looks_like_number(pTHX_ SV *sv)
1958 register char *send;
1959 register char *sbegin;
1960 register char *nbegin;
1968 else if (SvPOKp(sv))
1969 sbegin = SvPV(sv, len);
1972 send = sbegin + len;
1979 numtype = IS_NUMBER_NEG;
1986 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1987 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1991 /* next must be digit or the radix separator */
1995 } while (isDIGIT(*s));
1997 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1998 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
2000 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2003 #ifdef USE_LOCALE_NUMERIC
2004 || IS_NUMERIC_RADIX(*s)
2008 numtype |= IS_NUMBER_NOT_IV;
2009 while (isDIGIT(*s)) /* optional digits after the radix */
2014 #ifdef USE_LOCALE_NUMERIC
2015 || IS_NUMERIC_RADIX(*s)
2019 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
2020 /* no digits before the radix means we need digits after it */
2024 } while (isDIGIT(*s));
2032 /* we can have an optional exponent part */
2033 if (*s == 'e' || *s == 'E') {
2034 numtype &= ~IS_NUMBER_NEG;
2035 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
2037 if (*s == '+' || *s == '-')
2042 } while (isDIGIT(*s));
2051 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2052 return IS_NUMBER_TO_INT_BY_ATOL;
2057 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2060 return sv_2pv(sv, &n_a);
2063 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2065 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2068 char *ptr = buf + TYPE_CHARS(UV);
2083 *--ptr = '0' + (uv % 10);
2092 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2097 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2098 char *tmpbuf = tbuf;
2104 if (SvGMAGICAL(sv)) {
2112 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2114 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2119 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2124 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2126 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2133 if (SvTHINKFIRST(sv)) {
2136 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2137 return SvPV(tmpstr,*lp);
2144 switch (SvTYPE(sv)) {
2146 if ( ((SvFLAGS(sv) &
2147 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2148 == (SVs_OBJECT|SVs_RMG))
2149 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2150 && (mg = mg_find(sv, 'r'))) {
2152 regexp *re = (regexp *)mg->mg_obj;
2155 char *fptr = "msix";
2160 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2162 while(ch = *fptr++) {
2164 reflags[left++] = ch;
2167 reflags[right--] = ch;
2172 reflags[left] = '-';
2176 mg->mg_len = re->prelen + 4 + left;
2177 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2178 Copy("(?", mg->mg_ptr, 2, char);
2179 Copy(reflags, mg->mg_ptr+2, left, char);
2180 Copy(":", mg->mg_ptr+left+2, 1, char);
2181 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2182 mg->mg_ptr[mg->mg_len - 1] = ')';
2183 mg->mg_ptr[mg->mg_len] = 0;
2185 PL_reginterp_cnt += re->program[0].next_off;
2197 case SVt_PVBM: s = "SCALAR"; break;
2198 case SVt_PVLV: s = "LVALUE"; break;
2199 case SVt_PVAV: s = "ARRAY"; break;
2200 case SVt_PVHV: s = "HASH"; break;
2201 case SVt_PVCV: s = "CODE"; break;
2202 case SVt_PVGV: s = "GLOB"; break;
2203 case SVt_PVFM: s = "FORMAT"; break;
2204 case SVt_PVIO: s = "IO"; break;
2205 default: s = "UNKNOWN"; break;
2209 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2212 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2218 if (SvREADONLY(sv) && !SvOK(sv)) {
2220 if (ckWARN(WARN_UNINITIALIZED))
2226 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2227 /* XXXX 64-bit? IV may have better precision... */
2228 /* I tried changing this for to be 64-bit-aware and
2229 * the t/op/numconvert.t became very, very, angry.
2231 if (SvTYPE(sv) < SVt_PVNV)
2232 sv_upgrade(sv, SVt_PVNV);
2235 olderrno = errno; /* some Xenix systems wipe out errno here */
2237 if (SvNVX(sv) == 0.0)
2238 (void)strcpy(s,"0");
2242 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2245 #ifdef FIXNEGATIVEZERO
2246 if (*s == '-' && s[1] == '0' && !s[2])
2255 else if (SvIOKp(sv)) {
2256 U32 isIOK = SvIOK(sv);
2257 U32 isUIOK = SvIsUV(sv);
2258 char buf[TYPE_CHARS(UV)];
2261 if (SvTYPE(sv) < SVt_PVIV)
2262 sv_upgrade(sv, SVt_PVIV);
2264 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2266 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2267 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2268 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2269 SvCUR_set(sv, ebuf - ptr);
2282 if (ckWARN(WARN_UNINITIALIZED)
2283 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2288 if (SvTYPE(sv) < SVt_PV)
2289 /* Typically the caller expects that sv_any is not NULL now. */
2290 sv_upgrade(sv, SVt_PV);
2293 *lp = s - SvPVX(sv);
2296 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2297 PTR2UV(sv),SvPVX(sv)));
2301 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2302 /* Sneaky stuff here */
2306 tsv = newSVpv(tmpbuf, 0);
2322 len = strlen(tmpbuf);
2324 #ifdef FIXNEGATIVEZERO
2325 if (len == 2 && t[0] == '-' && t[1] == '0') {
2330 (void)SvUPGRADE(sv, SVt_PV);
2332 s = SvGROW(sv, len + 1);
2341 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2343 return sv_2pv_nolen(sv);
2347 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2349 return sv_2pv(sv,lp);
2353 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2355 return sv_2pv_nolen(sv);
2359 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2361 return sv_2pv(sv,lp);
2364 /* This function is only called on magical items */
2366 Perl_sv_2bool(pTHX_ register SV *sv)
2376 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2377 return SvTRUE(tmpsv);
2378 return SvRV(sv) != 0;
2381 register XPV* Xpvtmp;
2382 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2383 (*Xpvtmp->xpv_pv > '0' ||
2384 Xpvtmp->xpv_cur > 1 ||
2385 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2392 return SvIVX(sv) != 0;
2395 return SvNVX(sv) != 0.0;
2402 /* Note: sv_setsv() should not be called with a source string that needs
2403 * to be reused, since it may destroy the source string if it is marked
2408 =for apidoc sv_setsv
2410 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2411 The source SV may be destroyed if it is mortal. Does not handle 'set'
2412 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2419 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2422 register U32 sflags;
2428 SV_CHECK_THINKFIRST(dstr);
2430 sstr = &PL_sv_undef;
2431 stype = SvTYPE(sstr);
2432 dtype = SvTYPE(dstr);
2436 /* There's a lot of redundancy below but we're going for speed here */
2441 if (dtype != SVt_PVGV) {
2442 (void)SvOK_off(dstr);
2450 sv_upgrade(dstr, SVt_IV);
2453 sv_upgrade(dstr, SVt_PVNV);
2457 sv_upgrade(dstr, SVt_PVIV);
2460 (void)SvIOK_only(dstr);
2461 SvIVX(dstr) = SvIVX(sstr);
2474 sv_upgrade(dstr, SVt_NV);
2479 sv_upgrade(dstr, SVt_PVNV);
2482 SvNVX(dstr) = SvNVX(sstr);
2483 (void)SvNOK_only(dstr);
2491 sv_upgrade(dstr, SVt_RV);
2492 else if (dtype == SVt_PVGV &&
2493 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2496 if (GvIMPORTED(dstr) != GVf_IMPORTED
2497 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2499 GvIMPORTED_on(dstr);
2510 sv_upgrade(dstr, SVt_PV);
2513 if (dtype < SVt_PVIV)
2514 sv_upgrade(dstr, SVt_PVIV);
2517 if (dtype < SVt_PVNV)
2518 sv_upgrade(dstr, SVt_PVNV);
2525 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2526 PL_op_name[PL_op->op_type]);
2528 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2532 if (dtype <= SVt_PVGV) {
2534 if (dtype != SVt_PVGV) {
2535 char *name = GvNAME(sstr);
2536 STRLEN len = GvNAMELEN(sstr);
2537 sv_upgrade(dstr, SVt_PVGV);
2538 sv_magic(dstr, dstr, '*', name, len);
2539 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2540 GvNAME(dstr) = savepvn(name, len);
2541 GvNAMELEN(dstr) = len;
2542 SvFAKE_on(dstr); /* can coerce to non-glob */
2544 /* ahem, death to those who redefine active sort subs */
2545 else if (PL_curstackinfo->si_type == PERLSI_SORT
2546 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2547 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2549 (void)SvOK_off(dstr);
2550 GvINTRO_off(dstr); /* one-shot flag */
2552 GvGP(dstr) = gp_ref(GvGP(sstr));
2554 if (GvIMPORTED(dstr) != GVf_IMPORTED
2555 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2557 GvIMPORTED_on(dstr);
2565 if (SvGMAGICAL(sstr)) {
2567 if (SvTYPE(sstr) != stype) {
2568 stype = SvTYPE(sstr);
2569 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2573 if (stype == SVt_PVLV)
2574 (void)SvUPGRADE(dstr, SVt_PVNV);
2576 (void)SvUPGRADE(dstr, stype);
2579 sflags = SvFLAGS(sstr);
2581 if (sflags & SVf_ROK) {
2582 if (dtype >= SVt_PV) {
2583 if (dtype == SVt_PVGV) {
2584 SV *sref = SvREFCNT_inc(SvRV(sstr));
2586 int intro = GvINTRO(dstr);
2591 GvINTRO_off(dstr); /* one-shot flag */
2592 Newz(602,gp, 1, GP);
2593 GvGP(dstr) = gp_ref(gp);
2594 GvSV(dstr) = NEWSV(72,0);
2595 GvLINE(dstr) = CopLINE(PL_curcop);
2596 GvEGV(dstr) = (GV*)dstr;
2599 switch (SvTYPE(sref)) {
2602 SAVESPTR(GvAV(dstr));
2604 dref = (SV*)GvAV(dstr);
2605 GvAV(dstr) = (AV*)sref;
2606 if (GvIMPORTED_AV_off(dstr)
2607 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2609 GvIMPORTED_AV_on(dstr);
2614 SAVESPTR(GvHV(dstr));
2616 dref = (SV*)GvHV(dstr);
2617 GvHV(dstr) = (HV*)sref;
2618 if (GvIMPORTED_HV_off(dstr)
2619 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2621 GvIMPORTED_HV_on(dstr);
2626 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2627 SvREFCNT_dec(GvCV(dstr));
2628 GvCV(dstr) = Nullcv;
2629 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2630 PL_sub_generation++;
2632 SAVESPTR(GvCV(dstr));
2635 dref = (SV*)GvCV(dstr);
2636 if (GvCV(dstr) != (CV*)sref) {
2637 CV* cv = GvCV(dstr);
2639 if (!GvCVGEN((GV*)dstr) &&
2640 (CvROOT(cv) || CvXSUB(cv)))
2642 SV *const_sv = cv_const_sv(cv);
2643 bool const_changed = TRUE;
2645 const_changed = sv_cmp(const_sv,
2646 op_const_sv(CvSTART((CV*)sref),
2648 /* ahem, death to those who redefine
2649 * active sort subs */
2650 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2651 PL_sortcop == CvSTART(cv))
2653 "Can't redefine active sort subroutine %s",
2654 GvENAME((GV*)dstr));
2655 if (ckWARN(WARN_REDEFINE) || (const_changed && const_sv)) {
2656 if (!(CvGV(cv) && GvSTASH(CvGV(cv))
2657 && HvNAME(GvSTASH(CvGV(cv)))
2658 && strEQ(HvNAME(GvSTASH(CvGV(cv))),
2660 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2661 "Constant subroutine %s redefined"
2662 : "Subroutine %s redefined",
2663 GvENAME((GV*)dstr));
2666 cv_ckproto(cv, (GV*)dstr,
2667 SvPOK(sref) ? SvPVX(sref) : Nullch);
2669 GvCV(dstr) = (CV*)sref;
2670 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2671 GvASSUMECV_on(dstr);
2672 PL_sub_generation++;
2674 if (GvIMPORTED_CV_off(dstr)
2675 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2677 GvIMPORTED_CV_on(dstr);
2682 SAVESPTR(GvIOp(dstr));
2684 dref = (SV*)GvIOp(dstr);
2685 GvIOp(dstr) = (IO*)sref;
2689 SAVESPTR(GvSV(dstr));
2691 dref = (SV*)GvSV(dstr);
2693 if (GvIMPORTED_SV_off(dstr)
2694 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2696 GvIMPORTED_SV_on(dstr);
2708 (void)SvOOK_off(dstr); /* backoff */
2710 Safefree(SvPVX(dstr));
2711 SvLEN(dstr)=SvCUR(dstr)=0;
2714 (void)SvOK_off(dstr);
2715 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2717 if (sflags & SVp_NOK) {
2719 SvNVX(dstr) = SvNVX(sstr);
2721 if (sflags & SVp_IOK) {
2722 (void)SvIOK_on(dstr);
2723 SvIVX(dstr) = SvIVX(sstr);
2727 if (SvAMAGIC(sstr)) {
2731 else if (sflags & SVp_POK) {
2734 * Check to see if we can just swipe the string. If so, it's a
2735 * possible small lose on short strings, but a big win on long ones.
2736 * It might even be a win on short strings if SvPVX(dstr)
2737 * has to be allocated and SvPVX(sstr) has to be freed.
2740 if (SvTEMP(sstr) && /* slated for free anyway? */
2741 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2742 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2744 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2746 SvFLAGS(dstr) &= ~SVf_OOK;
2747 Safefree(SvPVX(dstr) - SvIVX(dstr));
2749 else if (SvLEN(dstr))
2750 Safefree(SvPVX(dstr));
2752 (void)SvPOK_only(dstr);
2753 SvPV_set(dstr, SvPVX(sstr));
2754 SvLEN_set(dstr, SvLEN(sstr));
2755 SvCUR_set(dstr, SvCUR(sstr));
2757 (void)SvOK_off(sstr);
2758 SvPV_set(sstr, Nullch);
2763 else { /* have to copy actual string */
2764 STRLEN len = SvCUR(sstr);
2766 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2767 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2768 SvCUR_set(dstr, len);
2769 *SvEND(dstr) = '\0';
2770 (void)SvPOK_only(dstr);
2775 if (sflags & SVp_NOK) {
2777 SvNVX(dstr) = SvNVX(sstr);
2779 if (sflags & SVp_IOK) {
2780 (void)SvIOK_on(dstr);
2781 SvIVX(dstr) = SvIVX(sstr);
2786 else if (sflags & SVp_NOK) {
2787 SvNVX(dstr) = SvNVX(sstr);
2788 (void)SvNOK_only(dstr);
2790 (void)SvIOK_on(dstr);
2791 SvIVX(dstr) = SvIVX(sstr);
2792 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2797 else if (sflags & SVp_IOK) {
2798 (void)SvIOK_only(dstr);
2799 SvIVX(dstr) = SvIVX(sstr);
2804 if (dtype == SVt_PVGV) {
2805 if (ckWARN(WARN_UNSAFE))
2806 Perl_warner(aTHX_ WARN_UNSAFE, "Undefined value assigned to typeglob");
2809 (void)SvOK_off(dstr);
2815 =for apidoc sv_setsv_mg
2817 Like C<sv_setsv>, but also handles 'set' magic.
2823 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2825 sv_setsv(dstr,sstr);
2830 =for apidoc sv_setpvn
2832 Copies a string into an SV. The C<len> parameter indicates the number of
2833 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2839 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2841 register char *dptr;
2842 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2843 elicit a warning, but it won't hurt. */
2844 SV_CHECK_THINKFIRST(sv);
2849 (void)SvUPGRADE(sv, SVt_PV);
2851 SvGROW(sv, len + 1);
2853 Move(ptr,dptr,len,char);
2856 (void)SvPOK_only(sv); /* validate pointer */
2861 =for apidoc sv_setpvn_mg
2863 Like C<sv_setpvn>, but also handles 'set' magic.
2869 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2871 sv_setpvn(sv,ptr,len);
2876 =for apidoc sv_setpv
2878 Copies a string into an SV. The string must be null-terminated. Does not
2879 handle 'set' magic. See C<sv_setpv_mg>.
2885 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2887 register STRLEN len;
2889 SV_CHECK_THINKFIRST(sv);
2895 (void)SvUPGRADE(sv, SVt_PV);
2897 SvGROW(sv, len + 1);
2898 Move(ptr,SvPVX(sv),len+1,char);
2900 (void)SvPOK_only(sv); /* validate pointer */
2905 =for apidoc sv_setpv_mg
2907 Like C<sv_setpv>, but also handles 'set' magic.
2913 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
2920 =for apidoc sv_usepvn
2922 Tells an SV to use C<ptr> to find its string value. Normally the string is
2923 stored inside the SV but sv_usepvn allows the SV to use an outside string.
2924 The C<ptr> should point to memory that was allocated by C<malloc>. The
2925 string length, C<len>, must be supplied. This function will realloc the
2926 memory pointed to by C<ptr>, so that pointer should not be freed or used by
2927 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
2928 See C<sv_usepvn_mg>.
2934 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2936 SV_CHECK_THINKFIRST(sv);
2937 (void)SvUPGRADE(sv, SVt_PV);
2942 (void)SvOOK_off(sv);
2943 if (SvPVX(sv) && SvLEN(sv))
2944 Safefree(SvPVX(sv));
2945 Renew(ptr, len+1, char);
2948 SvLEN_set(sv, len+1);
2950 (void)SvPOK_only(sv); /* validate pointer */
2955 =for apidoc sv_usepvn_mg
2957 Like C<sv_usepvn>, but also handles 'set' magic.
2963 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
2965 sv_usepvn(sv,ptr,len);
2970 Perl_sv_force_normal(pTHX_ register SV *sv)
2972 if (SvREADONLY(sv)) {
2974 if (PL_curcop != &PL_compiling)
2975 Perl_croak(aTHX_ PL_no_modify);
2979 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
2986 Efficient removal of characters from the beginning of the string buffer.
2987 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
2988 the string buffer. The C<ptr> becomes the first character of the adjusted
2995 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
2999 register STRLEN delta;
3001 if (!ptr || !SvPOKp(sv))
3003 SV_CHECK_THINKFIRST(sv);
3004 if (SvTYPE(sv) < SVt_PVIV)
3005 sv_upgrade(sv,SVt_PVIV);
3008 if (!SvLEN(sv)) { /* make copy of shared string */
3009 char *pvx = SvPVX(sv);
3010 STRLEN len = SvCUR(sv);
3011 SvGROW(sv, len + 1);
3012 Move(pvx,SvPVX(sv),len,char);
3016 SvFLAGS(sv) |= SVf_OOK;
3018 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3019 delta = ptr - SvPVX(sv);
3027 =for apidoc sv_catpvn
3029 Concatenates the string onto the end of the string which is in the SV. The
3030 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3031 'set' magic. See C<sv_catpvn_mg>.
3037 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3042 junk = SvPV_force(sv, tlen);
3043 SvGROW(sv, tlen + len + 1);
3046 Move(ptr,SvPVX(sv)+tlen,len,char);
3049 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3054 =for apidoc sv_catpvn_mg
3056 Like C<sv_catpvn>, but also handles 'set' magic.
3062 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3064 sv_catpvn(sv,ptr,len);
3069 =for apidoc sv_catsv
3071 Concatenates the string from SV C<ssv> onto the end of the string in SV
3072 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3078 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3084 if (s = SvPV(sstr, len))
3085 sv_catpvn(dstr,s,len);
3091 =for apidoc sv_catsv_mg
3093 Like C<sv_catsv>, but also handles 'set' magic.
3099 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3101 sv_catsv(dstr,sstr);
3106 =for apidoc sv_catpv
3108 Concatenates the string onto the end of the string which is in the SV.
3109 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3115 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3117 register STRLEN len;
3123 junk = SvPV_force(sv, tlen);
3125 SvGROW(sv, tlen + len + 1);
3128 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3130 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3135 =for apidoc sv_catpv_mg
3137 Like C<sv_catpv>, but also handles 'set' magic.
3143 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3150 Perl_newSV(pTHX_ STRLEN len)
3156 sv_upgrade(sv, SVt_PV);
3157 SvGROW(sv, len + 1);
3162 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3165 =for apidoc sv_magic
3167 Adds magic to an SV.
3173 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3177 if (SvREADONLY(sv)) {
3179 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3180 Perl_croak(aTHX_ PL_no_modify);
3182 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3183 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3190 (void)SvUPGRADE(sv, SVt_PVMG);
3192 Newz(702,mg, 1, MAGIC);
3193 mg->mg_moremagic = SvMAGIC(sv);
3196 if (!obj || obj == sv || how == '#' || how == 'r')
3200 mg->mg_obj = SvREFCNT_inc(obj);
3201 mg->mg_flags |= MGf_REFCOUNTED;
3204 mg->mg_len = namlen;
3207 mg->mg_ptr = savepvn(name, namlen);
3208 else if (namlen == HEf_SVKEY)
3209 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3213 mg->mg_virtual = &PL_vtbl_sv;
3216 mg->mg_virtual = &PL_vtbl_amagic;
3219 mg->mg_virtual = &PL_vtbl_amagicelem;
3225 mg->mg_virtual = &PL_vtbl_bm;
3228 mg->mg_virtual = &PL_vtbl_regdata;
3231 mg->mg_virtual = &PL_vtbl_regdatum;
3234 mg->mg_virtual = &PL_vtbl_env;
3237 mg->mg_virtual = &PL_vtbl_fm;
3240 mg->mg_virtual = &PL_vtbl_envelem;
3243 mg->mg_virtual = &PL_vtbl_mglob;
3246 mg->mg_virtual = &PL_vtbl_isa;
3249 mg->mg_virtual = &PL_vtbl_isaelem;
3252 mg->mg_virtual = &PL_vtbl_nkeys;
3259 mg->mg_virtual = &PL_vtbl_dbline;
3263 mg->mg_virtual = &PL_vtbl_mutex;
3265 #endif /* USE_THREADS */
3266 #ifdef USE_LOCALE_COLLATE
3268 mg->mg_virtual = &PL_vtbl_collxfrm;
3270 #endif /* USE_LOCALE_COLLATE */
3272 mg->mg_virtual = &PL_vtbl_pack;
3276 mg->mg_virtual = &PL_vtbl_packelem;
3279 mg->mg_virtual = &PL_vtbl_regexp;
3282 mg->mg_virtual = &PL_vtbl_sig;
3285 mg->mg_virtual = &PL_vtbl_sigelem;
3288 mg->mg_virtual = &PL_vtbl_taint;
3292 mg->mg_virtual = &PL_vtbl_uvar;
3295 mg->mg_virtual = &PL_vtbl_vec;
3298 mg->mg_virtual = &PL_vtbl_substr;
3301 mg->mg_virtual = &PL_vtbl_defelem;
3304 mg->mg_virtual = &PL_vtbl_glob;
3307 mg->mg_virtual = &PL_vtbl_arylen;
3310 mg->mg_virtual = &PL_vtbl_pos;
3313 mg->mg_virtual = &PL_vtbl_backref;
3315 case '~': /* Reserved for use by extensions not perl internals. */
3316 /* Useful for attaching extension internal data to perl vars. */
3317 /* Note that multiple extensions may clash if magical scalars */
3318 /* etc holding private data from one are passed to another. */
3322 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3326 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3330 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3334 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3337 for (mg = *mgp; mg; mg = *mgp) {
3338 if (mg->mg_type == type) {
3339 MGVTBL* vtbl = mg->mg_virtual;
3340 *mgp = mg->mg_moremagic;
3341 if (vtbl && vtbl->svt_free)
3342 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3343 if (mg->mg_ptr && mg->mg_type != 'g')
3344 if (mg->mg_len >= 0)
3345 Safefree(mg->mg_ptr);
3346 else if (mg->mg_len == HEf_SVKEY)
3347 SvREFCNT_dec((SV*)mg->mg_ptr);
3348 if (mg->mg_flags & MGf_REFCOUNTED)
3349 SvREFCNT_dec(mg->mg_obj);
3353 mgp = &mg->mg_moremagic;
3357 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3364 Perl_sv_rvweaken(pTHX_ SV *sv)
3367 if (!SvOK(sv)) /* let undefs pass */
3370 Perl_croak(aTHX_ "Can't weaken a nonreference");
3371 else if (SvWEAKREF(sv)) {
3373 if (ckWARN(WARN_MISC))
3374 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3378 sv_add_backref(tsv, sv);
3385 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3389 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3390 av = (AV*)mg->mg_obj;
3393 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3394 SvREFCNT_dec(av); /* for sv_magic */
3400 S_sv_del_backref(pTHX_ SV *sv)
3407 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3408 Perl_croak(aTHX_ "panic: del_backref");
3409 av = (AV *)mg->mg_obj;
3414 svp[i] = &PL_sv_undef; /* XXX */
3421 =for apidoc sv_insert
3423 Inserts a string at the specified offset/length within the SV. Similar to
3424 the Perl substr() function.
3430 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3434 register char *midend;
3435 register char *bigend;
3441 Perl_croak(aTHX_ "Can't modify non-existent substring");
3442 SvPV_force(bigstr, curlen);
3443 if (offset + len > curlen) {
3444 SvGROW(bigstr, offset+len+1);
3445 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3446 SvCUR_set(bigstr, offset+len);
3450 i = littlelen - len;
3451 if (i > 0) { /* string might grow */
3452 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3453 mid = big + offset + len;
3454 midend = bigend = big + SvCUR(bigstr);
3457 while (midend > mid) /* shove everything down */
3458 *--bigend = *--midend;
3459 Move(little,big+offset,littlelen,char);
3465 Move(little,SvPVX(bigstr)+offset,len,char);
3470 big = SvPVX(bigstr);
3473 bigend = big + SvCUR(bigstr);
3475 if (midend > bigend)
3476 Perl_croak(aTHX_ "panic: sv_insert");
3478 if (mid - big > bigend - midend) { /* faster to shorten from end */
3480 Move(little, mid, littlelen,char);
3483 i = bigend - midend;
3485 Move(midend, mid, i,char);
3489 SvCUR_set(bigstr, mid - big);
3492 else if (i = mid - big) { /* faster from front */
3493 midend -= littlelen;
3495 sv_chop(bigstr,midend-i);
3500 Move(little, mid, littlelen,char);
3502 else if (littlelen) {
3503 midend -= littlelen;
3504 sv_chop(bigstr,midend);
3505 Move(little,midend,littlelen,char);
3508 sv_chop(bigstr,midend);
3513 /* make sv point to what nstr did */
3516 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3519 U32 refcnt = SvREFCNT(sv);
3520 SV_CHECK_THINKFIRST(sv);
3521 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3522 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3523 if (SvMAGICAL(sv)) {
3527 sv_upgrade(nsv, SVt_PVMG);
3528 SvMAGIC(nsv) = SvMAGIC(sv);
3529 SvFLAGS(nsv) |= SvMAGICAL(sv);
3535 assert(!SvREFCNT(sv));
3536 StructCopy(nsv,sv,SV);
3537 SvREFCNT(sv) = refcnt;
3538 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3543 Perl_sv_clear(pTHX_ register SV *sv)
3547 assert(SvREFCNT(sv) == 0);
3551 if (PL_defstash) { /* Still have a symbol table? */
3556 Zero(&tmpref, 1, SV);
3557 sv_upgrade(&tmpref, SVt_RV);
3559 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3560 SvREFCNT(&tmpref) = 1;
3563 stash = SvSTASH(sv);
3564 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3567 PUSHSTACKi(PERLSI_DESTROY);
3568 SvRV(&tmpref) = SvREFCNT_inc(sv);
3573 call_sv((SV*)GvCV(destructor),
3574 G_DISCARD|G_EVAL|G_KEEPERR);
3580 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3582 del_XRV(SvANY(&tmpref));
3585 if (PL_in_clean_objs)
3586 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3588 /* DESTROY gave object new lease on life */
3594 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3595 SvOBJECT_off(sv); /* Curse the object. */
3596 if (SvTYPE(sv) != SVt_PVIO)
3597 --PL_sv_objcount; /* XXX Might want something more general */
3600 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3603 switch (SvTYPE(sv)) {
3606 IoIFP(sv) != PerlIO_stdin() &&
3607 IoIFP(sv) != PerlIO_stdout() &&
3608 IoIFP(sv) != PerlIO_stderr())
3610 io_close((IO*)sv, FALSE);
3612 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3613 PerlDir_close(IoDIRP(sv));
3614 IoDIRP(sv) = (DIR*)NULL;
3615 Safefree(IoTOP_NAME(sv));
3616 Safefree(IoFMT_NAME(sv));
3617 Safefree(IoBOTTOM_NAME(sv));
3632 SvREFCNT_dec(LvTARG(sv));
3636 Safefree(GvNAME(sv));
3637 /* cannot decrease stash refcount yet, as we might recursively delete
3638 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3639 of stash until current sv is completely gone.
3640 -- JohnPC, 27 Mar 1998 */
3641 stash = GvSTASH(sv);
3647 (void)SvOOK_off(sv);
3655 SvREFCNT_dec(SvRV(sv));
3657 else if (SvPVX(sv) && SvLEN(sv))
3658 Safefree(SvPVX(sv));
3668 switch (SvTYPE(sv)) {
3684 del_XPVIV(SvANY(sv));
3687 del_XPVNV(SvANY(sv));
3690 del_XPVMG(SvANY(sv));
3693 del_XPVLV(SvANY(sv));
3696 del_XPVAV(SvANY(sv));
3699 del_XPVHV(SvANY(sv));
3702 del_XPVCV(SvANY(sv));
3705 del_XPVGV(SvANY(sv));
3706 /* code duplication for increased performance. */
3707 SvFLAGS(sv) &= SVf_BREAK;
3708 SvFLAGS(sv) |= SVTYPEMASK;
3709 /* decrease refcount of the stash that owns this GV, if any */
3711 SvREFCNT_dec(stash);
3712 return; /* not break, SvFLAGS reset already happened */
3714 del_XPVBM(SvANY(sv));
3717 del_XPVFM(SvANY(sv));
3720 del_XPVIO(SvANY(sv));
3723 SvFLAGS(sv) &= SVf_BREAK;
3724 SvFLAGS(sv) |= SVTYPEMASK;
3728 Perl_sv_newref(pTHX_ SV *sv)
3731 ATOMIC_INC(SvREFCNT(sv));
3736 Perl_sv_free(pTHX_ SV *sv)
3739 int refcount_is_zero;
3743 if (SvREFCNT(sv) == 0) {
3744 if (SvFLAGS(sv) & SVf_BREAK)
3746 if (PL_in_clean_all) /* All is fair */
3748 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3749 /* make sure SvREFCNT(sv)==0 happens very seldom */
3750 SvREFCNT(sv) = (~(U32)0)/2;
3753 if (ckWARN_d(WARN_INTERNAL))
3754 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3757 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3758 if (!refcount_is_zero)
3762 if (ckWARN_d(WARN_DEBUGGING))
3763 Perl_warner(aTHX_ WARN_DEBUGGING,
3764 "Attempt to free temp prematurely: SV 0x%"UVxf,
3769 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3770 /* make sure SvREFCNT(sv)==0 happens very seldom */
3771 SvREFCNT(sv) = (~(U32)0)/2;
3782 Returns the length of the string in the SV. See also C<SvCUR>.
3788 Perl_sv_len(pTHX_ register SV *sv)
3797 len = mg_length(sv);
3799 junk = SvPV(sv, len);
3804 Perl_sv_len_utf8(pTHX_ register SV *sv)
3815 len = mg_length(sv);
3818 s = (U8*)SvPV(sv, len);
3829 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3834 I32 uoffset = *offsetp;
3840 start = s = (U8*)SvPV(sv, len);
3842 while (s < send && uoffset--)
3846 *offsetp = s - start;
3850 while (s < send && ulen--)
3860 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3869 s = (U8*)SvPV(sv, len);
3871 Perl_croak(aTHX_ "panic: bad byte offset");
3872 send = s + *offsetp;
3880 if (ckWARN_d(WARN_UTF8))
3881 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
3891 Returns a boolean indicating whether the strings in the two SVs are
3898 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
3910 pv1 = SvPV(str1, cur1);
3915 pv2 = SvPV(str2, cur2);
3920 return memEQ(pv1, pv2, cur1);
3926 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
3927 string in C<sv1> is less than, equal to, or greater than the string in
3934 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
3937 char *pv1 = str1 ? SvPV(str1, cur1) : (char *) NULL;
3939 char *pv2 = str2 ? SvPV(str2, cur2) : (char *) NULL;
3943 return cur2 ? -1 : 0;
3948 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
3951 return retval < 0 ? -1 : 1;
3956 return cur1 < cur2 ? -1 : 1;
3960 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
3962 #ifdef USE_LOCALE_COLLATE
3968 if (PL_collation_standard)
3972 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
3974 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
3976 if (!pv1 || !len1) {
3987 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
3990 return retval < 0 ? -1 : 1;
3993 * When the result of collation is equality, that doesn't mean
3994 * that there are no differences -- some locales exclude some
3995 * characters from consideration. So to avoid false equalities,
3996 * we use the raw string as a tiebreaker.
4002 #endif /* USE_LOCALE_COLLATE */
4004 return sv_cmp(sv1, sv2);
4007 #ifdef USE_LOCALE_COLLATE
4009 * Any scalar variable may carry an 'o' magic that contains the
4010 * scalar data of the variable transformed to such a format that
4011 * a normal memory comparison can be used to compare the data
4012 * according to the locale settings.
4015 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4019 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4020 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4025 Safefree(mg->mg_ptr);
4027 if ((xf = mem_collxfrm(s, len, &xlen))) {
4028 if (SvREADONLY(sv)) {
4031 return xf + sizeof(PL_collation_ix);
4034 sv_magic(sv, 0, 'o', 0, 0);
4035 mg = mg_find(sv, 'o');
4048 if (mg && mg->mg_ptr) {
4050 return mg->mg_ptr + sizeof(PL_collation_ix);
4058 #endif /* USE_LOCALE_COLLATE */
4061 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4066 register STDCHAR rslast;
4067 register STDCHAR *bp;
4071 SV_CHECK_THINKFIRST(sv);
4072 (void)SvUPGRADE(sv, SVt_PV);
4076 if (RsSNARF(PL_rs)) {
4080 else if (RsRECORD(PL_rs)) {
4081 I32 recsize, bytesread;
4084 /* Grab the size of the record we're getting */
4085 recsize = SvIV(SvRV(PL_rs));
4086 (void)SvPOK_only(sv); /* Validate pointer */
4087 buffer = SvGROW(sv, recsize + 1);
4090 /* VMS wants read instead of fread, because fread doesn't respect */
4091 /* RMS record boundaries. This is not necessarily a good thing to be */
4092 /* doing, but we've got no other real choice */
4093 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4095 bytesread = PerlIO_read(fp, buffer, recsize);
4097 SvCUR_set(sv, bytesread);
4098 buffer[bytesread] = '\0';
4099 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4101 else if (RsPARA(PL_rs)) {
4106 rsptr = SvPV(PL_rs, rslen);
4107 rslast = rslen ? rsptr[rslen - 1] : '\0';
4109 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4110 do { /* to make sure file boundaries work right */
4113 i = PerlIO_getc(fp);
4117 PerlIO_ungetc(fp,i);
4123 /* See if we know enough about I/O mechanism to cheat it ! */
4125 /* This used to be #ifdef test - it is made run-time test for ease
4126 of abstracting out stdio interface. One call should be cheap
4127 enough here - and may even be a macro allowing compile
4131 if (PerlIO_fast_gets(fp)) {
4134 * We're going to steal some values from the stdio struct
4135 * and put EVERYTHING in the innermost loop into registers.
4137 register STDCHAR *ptr;
4141 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4142 /* An ungetc()d char is handled separately from the regular
4143 * buffer, so we getc() it back out and stuff it in the buffer.
4145 i = PerlIO_getc(fp);
4146 if (i == EOF) return 0;
4147 *(--((*fp)->_ptr)) = (unsigned char) i;
4151 /* Here is some breathtakingly efficient cheating */
4153 cnt = PerlIO_get_cnt(fp); /* get count into register */
4154 (void)SvPOK_only(sv); /* validate pointer */
4155 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4156 if (cnt > 80 && SvLEN(sv) > append) {
4157 shortbuffered = cnt - SvLEN(sv) + append + 1;
4158 cnt -= shortbuffered;
4162 /* remember that cnt can be negative */
4163 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4168 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4169 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4170 DEBUG_P(PerlIO_printf(Perl_debug_log,
4171 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4172 DEBUG_P(PerlIO_printf(Perl_debug_log,
4173 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4174 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4175 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4180 while (cnt > 0) { /* this | eat */
4182 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4183 goto thats_all_folks; /* screams | sed :-) */
4187 Copy(ptr, bp, cnt, char); /* this | eat */
4188 bp += cnt; /* screams | dust */
4189 ptr += cnt; /* louder | sed :-) */
4194 if (shortbuffered) { /* oh well, must extend */
4195 cnt = shortbuffered;
4197 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4199 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4200 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4204 DEBUG_P(PerlIO_printf(Perl_debug_log,
4205 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4206 PTR2UV(ptr),(long)cnt));
4207 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4208 DEBUG_P(PerlIO_printf(Perl_debug_log,
4209 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4210 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4211 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4212 /* This used to call 'filbuf' in stdio form, but as that behaves like
4213 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4214 another abstraction. */
4215 i = PerlIO_getc(fp); /* get more characters */
4216 DEBUG_P(PerlIO_printf(Perl_debug_log,
4217 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4218 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4219 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4220 cnt = PerlIO_get_cnt(fp);
4221 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4222 DEBUG_P(PerlIO_printf(Perl_debug_log,
4223 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4225 if (i == EOF) /* all done for ever? */
4226 goto thats_really_all_folks;
4228 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4230 SvGROW(sv, bpx + cnt + 2);
4231 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4233 *bp++ = i; /* store character from PerlIO_getc */
4235 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4236 goto thats_all_folks;
4240 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4241 memNE((char*)bp - rslen, rsptr, rslen))
4242 goto screamer; /* go back to the fray */
4243 thats_really_all_folks:
4245 cnt += shortbuffered;
4246 DEBUG_P(PerlIO_printf(Perl_debug_log,
4247 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4248 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4249 DEBUG_P(PerlIO_printf(Perl_debug_log,
4250 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4251 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4252 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4254 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4255 DEBUG_P(PerlIO_printf(Perl_debug_log,
4256 "Screamer: done, len=%ld, string=|%.*s|\n",
4257 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4262 /*The big, slow, and stupid way */
4265 /* Need to work around EPOC SDK features */
4266 /* On WINS: MS VC5 generates calls to _chkstk, */
4267 /* if a `large' stack frame is allocated */
4268 /* gcc on MARM does not generate calls like these */
4274 register STDCHAR *bpe = buf + sizeof(buf);
4276 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4277 ; /* keep reading */
4281 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4282 /* Accomodate broken VAXC compiler, which applies U8 cast to
4283 * both args of ?: operator, causing EOF to change into 255
4285 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4289 sv_catpvn(sv, (char *) buf, cnt);
4291 sv_setpvn(sv, (char *) buf, cnt);
4293 if (i != EOF && /* joy */
4295 SvCUR(sv) < rslen ||
4296 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4300 * If we're reading from a TTY and we get a short read,
4301 * indicating that the user hit his EOF character, we need
4302 * to notice it now, because if we try to read from the TTY
4303 * again, the EOF condition will disappear.
4305 * The comparison of cnt to sizeof(buf) is an optimization
4306 * that prevents unnecessary calls to feof().
4310 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4315 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4316 while (i != EOF) { /* to make sure file boundaries work right */
4317 i = PerlIO_getc(fp);
4319 PerlIO_ungetc(fp,i);
4325 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4332 Auto-increment of the value in the SV.
4338 Perl_sv_inc(pTHX_ register SV *sv)
4347 if (SvTHINKFIRST(sv)) {
4348 if (SvREADONLY(sv)) {
4350 if (PL_curcop != &PL_compiling)
4351 Perl_croak(aTHX_ PL_no_modify);
4355 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4357 i = PTR2IV(SvRV(sv));
4362 flags = SvFLAGS(sv);
4363 if (flags & SVp_NOK) {
4364 (void)SvNOK_only(sv);
4368 if (flags & SVp_IOK) {
4370 if (SvUVX(sv) == UV_MAX)
4371 sv_setnv(sv, (NV)UV_MAX + 1.0);
4373 (void)SvIOK_only_UV(sv);
4376 if (SvIVX(sv) == IV_MAX)
4377 sv_setnv(sv, (NV)IV_MAX + 1.0);
4379 (void)SvIOK_only(sv);
4385 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4386 if ((flags & SVTYPEMASK) < SVt_PVNV)
4387 sv_upgrade(sv, SVt_NV);
4389 (void)SvNOK_only(sv);
4393 while (isALPHA(*d)) d++;
4394 while (isDIGIT(*d)) d++;
4396 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4400 while (d >= SvPVX(sv)) {
4408 /* MKS: The original code here died if letters weren't consecutive.
4409 * at least it didn't have to worry about non-C locales. The
4410 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4411 * arranged in order (although not consecutively) and that only
4412 * [A-Za-z] are accepted by isALPHA in the C locale.
4414 if (*d != 'z' && *d != 'Z') {
4415 do { ++*d; } while (!isALPHA(*d));
4418 *(d--) -= 'z' - 'a';
4423 *(d--) -= 'z' - 'a' + 1;
4427 /* oh,oh, the number grew */
4428 SvGROW(sv, SvCUR(sv) + 2);
4430 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4441 Auto-decrement of the value in the SV.
4447 Perl_sv_dec(pTHX_ register SV *sv)
4455 if (SvTHINKFIRST(sv)) {
4456 if (SvREADONLY(sv)) {
4458 if (PL_curcop != &PL_compiling)
4459 Perl_croak(aTHX_ PL_no_modify);
4463 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4465 i = PTR2IV(SvRV(sv));
4470 flags = SvFLAGS(sv);
4471 if (flags & SVp_NOK) {
4473 (void)SvNOK_only(sv);
4476 if (flags & SVp_IOK) {
4478 if (SvUVX(sv) == 0) {
4479 (void)SvIOK_only(sv);
4483 (void)SvIOK_only_UV(sv);
4487 if (SvIVX(sv) == IV_MIN)
4488 sv_setnv(sv, (NV)IV_MIN - 1.0);
4490 (void)SvIOK_only(sv);
4496 if (!(flags & SVp_POK)) {
4497 if ((flags & SVTYPEMASK) < SVt_PVNV)
4498 sv_upgrade(sv, SVt_NV);
4500 (void)SvNOK_only(sv);
4503 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4507 =for apidoc sv_mortalcopy
4509 Creates a new SV which is a copy of the original SV. The new SV is marked
4515 /* Make a string that will exist for the duration of the expression
4516 * evaluation. Actually, it may have to last longer than that, but
4517 * hopefully we won't free it until it has been assigned to a
4518 * permanent location. */
4521 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4527 sv_setsv(sv,oldstr);
4529 PL_tmps_stack[++PL_tmps_ix] = sv;
4535 =for apidoc sv_newmortal
4537 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4543 Perl_sv_newmortal(pTHX)
4549 SvFLAGS(sv) = SVs_TEMP;
4551 PL_tmps_stack[++PL_tmps_ix] = sv;
4556 =for apidoc sv_2mortal
4558 Marks an SV as mortal. The SV will be destroyed when the current context
4564 /* same thing without the copying */
4567 Perl_sv_2mortal(pTHX_ register SV *sv)
4572 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4575 PL_tmps_stack[++PL_tmps_ix] = sv;
4583 Creates a new SV and copies a string into it. The reference count for the
4584 SV is set to 1. If C<len> is zero, Perl will compute the length using
4585 strlen(). For efficiency, consider using C<newSVpvn> instead.
4591 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4598 sv_setpvn(sv,s,len);
4603 =for apidoc newSVpvn
4605 Creates a new SV and copies a string into it. The reference count for the
4606 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4607 string. You are responsible for ensuring that the source string is at least
4614 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4619 sv_setpvn(sv,s,len);
4623 #if defined(PERL_IMPLICIT_CONTEXT)
4625 Perl_newSVpvf_nocontext(const char* pat, ...)
4630 va_start(args, pat);
4631 sv = vnewSVpvf(pat, &args);
4638 =for apidoc newSVpvf
4640 Creates a new SV an initialize it with the string formatted like
4647 Perl_newSVpvf(pTHX_ const char* pat, ...)
4651 va_start(args, pat);
4652 sv = vnewSVpvf(pat, &args);
4658 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4662 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4669 Creates a new SV and copies a floating point value into it.
4670 The reference count for the SV is set to 1.
4676 Perl_newSVnv(pTHX_ NV n)
4688 Creates a new SV and copies an integer into it. The reference count for the
4695 Perl_newSViv(pTHX_ IV i)
4705 =for apidoc newRV_noinc
4707 Creates an RV wrapper for an SV. The reference count for the original
4708 SV is B<not> incremented.
4714 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4720 sv_upgrade(sv, SVt_RV);
4727 /* newRV_inc is #defined to newRV in sv.h */
4729 Perl_newRV(pTHX_ SV *tmpRef)
4731 return newRV_noinc(SvREFCNT_inc(tmpRef));
4737 Creates a new SV which is an exact duplicate of the original SV.
4742 /* make an exact duplicate of old */
4745 Perl_newSVsv(pTHX_ register SV *old)
4752 if (SvTYPE(old) == SVTYPEMASK) {
4753 if (ckWARN_d(WARN_INTERNAL))
4754 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4769 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4777 char todo[PERL_UCHAR_MAX+1];
4782 if (!*s) { /* reset ?? searches */
4783 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4784 pm->op_pmdynflags &= ~PMdf_USED;
4789 /* reset variables */
4791 if (!HvARRAY(stash))
4794 Zero(todo, 256, char);
4796 i = (unsigned char)*s;
4800 max = (unsigned char)*s++;
4801 for ( ; i <= max; i++) {
4804 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4805 for (entry = HvARRAY(stash)[i];
4807 entry = HeNEXT(entry))
4809 if (!todo[(U8)*HeKEY(entry)])
4811 gv = (GV*)HeVAL(entry);
4813 if (SvTHINKFIRST(sv)) {
4814 if (!SvREADONLY(sv) && SvROK(sv))
4819 if (SvTYPE(sv) >= SVt_PV) {
4821 if (SvPVX(sv) != Nullch)
4828 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
4830 #ifndef VMS /* VMS has no environ array */
4832 environ[0] = Nullch;
4841 Perl_sv_2io(pTHX_ SV *sv)
4847 switch (SvTYPE(sv)) {
4855 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
4859 Perl_croak(aTHX_ PL_no_usym, "filehandle");
4861 return sv_2io(SvRV(sv));
4862 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
4868 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
4875 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
4882 return *gvp = Nullgv, Nullcv;
4883 switch (SvTYPE(sv)) {
4903 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
4904 tryAMAGICunDEREF(to_cv);
4907 if (SvTYPE(sv) == SVt_PVCV) {
4916 Perl_croak(aTHX_ "Not a subroutine reference");
4921 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
4927 if (lref && !GvCVu(gv)) {
4930 tmpsv = NEWSV(704,0);
4931 gv_efullname3(tmpsv, gv, Nullch);
4932 /* XXX this is probably not what they think they're getting.
4933 * It has the same effect as "sub name;", i.e. just a forward
4935 newSUB(start_subparse(FALSE, 0),
4936 newSVOP(OP_CONST, 0, tmpsv),
4941 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
4948 Perl_sv_true(pTHX_ register SV *sv)
4955 if ((tXpv = (XPV*)SvANY(sv)) &&
4956 (tXpv->xpv_cur > 1 ||
4957 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
4964 return SvIVX(sv) != 0;
4967 return SvNVX(sv) != 0.0;
4969 return sv_2bool(sv);
4975 Perl_sv_iv(pTHX_ register SV *sv)
4979 return (IV)SvUVX(sv);
4986 Perl_sv_uv(pTHX_ register SV *sv)
4991 return (UV)SvIVX(sv);
4997 Perl_sv_nv(pTHX_ register SV *sv)
5005 Perl_sv_pv(pTHX_ SV *sv)
5012 return sv_2pv(sv, &n_a);
5016 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5022 return sv_2pv(sv, lp);
5026 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5030 if (SvTHINKFIRST(sv) && !SvROK(sv))
5031 sv_force_normal(sv);
5037 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5039 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5040 PL_op_name[PL_op->op_type]);
5044 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5049 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5050 SvGROW(sv, len + 1);
5051 Move(s,SvPVX(sv),len,char);
5056 SvPOK_on(sv); /* validate pointer */
5058 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5059 PTR2UV(sv),SvPVX(sv)));
5066 Perl_sv_pvbyte(pTHX_ SV *sv)
5072 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5074 return sv_pvn(sv,lp);
5078 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5080 return sv_pvn_force(sv,lp);
5084 Perl_sv_pvutf8(pTHX_ SV *sv)
5090 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5092 return sv_pvn(sv,lp);
5096 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5098 return sv_pvn_force(sv,lp);
5102 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5104 if (ob && SvOBJECT(sv))
5105 return HvNAME(SvSTASH(sv));
5107 switch (SvTYPE(sv)) {
5121 case SVt_PVLV: return "LVALUE";
5122 case SVt_PVAV: return "ARRAY";
5123 case SVt_PVHV: return "HASH";
5124 case SVt_PVCV: return "CODE";
5125 case SVt_PVGV: return "GLOB";
5126 case SVt_PVFM: return "FORMAT";
5127 default: return "UNKNOWN";
5133 =for apidoc sv_isobject
5135 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5136 object. If the SV is not an RV, or if the object is not blessed, then this
5143 Perl_sv_isobject(pTHX_ SV *sv)
5160 Returns a boolean indicating whether the SV is blessed into the specified
5161 class. This does not check for subtypes; use C<sv_derived_from> to verify
5162 an inheritance relationship.
5168 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5180 return strEQ(HvNAME(SvSTASH(sv)), name);
5186 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5187 it will be upgraded to one. If C<classname> is non-null then the new SV will
5188 be blessed in the specified package. The new SV is returned and its
5189 reference count is 1.
5195 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5202 SV_CHECK_THINKFIRST(rv);
5205 if (SvTYPE(rv) < SVt_RV)
5206 sv_upgrade(rv, SVt_RV);
5213 HV* stash = gv_stashpv(classname, TRUE);
5214 (void)sv_bless(rv, stash);
5220 =for apidoc sv_setref_pv
5222 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5223 argument will be upgraded to an RV. That RV will be modified to point to
5224 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5225 into the SV. The C<classname> argument indicates the package for the
5226 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5227 will be returned and will have a reference count of 1.
5229 Do not use with other Perl types such as HV, AV, SV, CV, because those
5230 objects will become corrupted by the pointer copy process.
5232 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5238 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5241 sv_setsv(rv, &PL_sv_undef);
5245 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5250 =for apidoc sv_setref_iv
5252 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5253 argument will be upgraded to an RV. That RV will be modified to point to
5254 the new SV. The C<classname> argument indicates the package for the
5255 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5256 will be returned and will have a reference count of 1.
5262 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5264 sv_setiv(newSVrv(rv,classname), iv);
5269 =for apidoc sv_setref_nv
5271 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5272 argument will be upgraded to an RV. That RV will be modified to point to
5273 the new SV. The C<classname> argument indicates the package for the
5274 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5275 will be returned and will have a reference count of 1.
5281 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5283 sv_setnv(newSVrv(rv,classname), nv);
5288 =for apidoc sv_setref_pvn
5290 Copies a string into a new SV, optionally blessing the SV. The length of the
5291 string must be specified with C<n>. The C<rv> argument will be upgraded to
5292 an RV. That RV will be modified to point to the new SV. The C<classname>
5293 argument indicates the package for the blessing. Set C<classname> to
5294 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5295 a reference count of 1.
5297 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5303 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5305 sv_setpvn(newSVrv(rv,classname), pv, n);
5310 =for apidoc sv_bless
5312 Blesses an SV into a specified package. The SV must be an RV. The package
5313 must be designated by its stash (see C<gv_stashpv()>). The reference count
5314 of the SV is unaffected.
5320 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5325 Perl_croak(aTHX_ "Can't bless non-reference value");
5327 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5328 if (SvREADONLY(tmpRef))
5329 Perl_croak(aTHX_ PL_no_modify);
5330 if (SvOBJECT(tmpRef)) {
5331 if (SvTYPE(tmpRef) != SVt_PVIO)
5333 SvREFCNT_dec(SvSTASH(tmpRef));
5336 SvOBJECT_on(tmpRef);
5337 if (SvTYPE(tmpRef) != SVt_PVIO)
5339 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5340 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5351 S_sv_unglob(pTHX_ SV *sv)
5353 assert(SvTYPE(sv) == SVt_PVGV);
5358 SvREFCNT_dec(GvSTASH(sv));
5359 GvSTASH(sv) = Nullhv;
5361 sv_unmagic(sv, '*');
5362 Safefree(GvNAME(sv));
5364 SvFLAGS(sv) &= ~SVTYPEMASK;
5365 SvFLAGS(sv) |= SVt_PVMG;
5369 =for apidoc sv_unref
5371 Unsets the RV status of the SV, and decrements the reference count of
5372 whatever was being referenced by the RV. This can almost be thought of
5373 as a reversal of C<newSVrv>. See C<SvROK_off>.
5379 Perl_sv_unref(pTHX_ SV *sv)
5383 if (SvWEAKREF(sv)) {
5391 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5394 sv_2mortal(rv); /* Schedule for freeing later */
5398 Perl_sv_taint(pTHX_ SV *sv)
5400 sv_magic((sv), Nullsv, 't', Nullch, 0);
5404 Perl_sv_untaint(pTHX_ SV *sv)
5406 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5407 MAGIC *mg = mg_find(sv, 't');
5414 Perl_sv_tainted(pTHX_ SV *sv)
5416 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5417 MAGIC *mg = mg_find(sv, 't');
5418 if (mg && ((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv))
5425 =for apidoc sv_setpviv
5427 Copies an integer into the given SV, also updating its string value.
5428 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5434 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5436 char buf[TYPE_CHARS(UV)];
5438 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5440 sv_setpvn(sv, ptr, ebuf - ptr);
5445 =for apidoc sv_setpviv_mg
5447 Like C<sv_setpviv>, but also handles 'set' magic.
5453 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5455 char buf[TYPE_CHARS(UV)];
5457 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5459 sv_setpvn(sv, ptr, ebuf - ptr);
5463 #if defined(PERL_IMPLICIT_CONTEXT)
5465 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5469 va_start(args, pat);
5470 sv_vsetpvf(sv, pat, &args);
5476 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5480 va_start(args, pat);
5481 sv_vsetpvf_mg(sv, pat, &args);
5487 =for apidoc sv_setpvf
5489 Processes its arguments like C<sprintf> and sets an SV to the formatted
5490 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5496 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5499 va_start(args, pat);
5500 sv_vsetpvf(sv, pat, &args);
5505 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5507 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5511 =for apidoc sv_setpvf_mg
5513 Like C<sv_setpvf>, but also handles 'set' magic.
5519 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5522 va_start(args, pat);
5523 sv_vsetpvf_mg(sv, pat, &args);
5528 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5530 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5534 #if defined(PERL_IMPLICIT_CONTEXT)
5536 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5540 va_start(args, pat);
5541 sv_vcatpvf(sv, pat, &args);
5546 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5550 va_start(args, pat);
5551 sv_vcatpvf_mg(sv, pat, &args);
5557 =for apidoc sv_catpvf
5559 Processes its arguments like C<sprintf> and appends the formatted output
5560 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5561 typically be called after calling this function to handle 'set' magic.
5567 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5570 va_start(args, pat);
5571 sv_vcatpvf(sv, pat, &args);
5576 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5578 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5582 =for apidoc sv_catpvf_mg
5584 Like C<sv_catpvf>, but also handles 'set' magic.
5590 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5593 va_start(args, pat);
5594 sv_vcatpvf_mg(sv, pat, &args);
5599 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5601 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5606 =for apidoc sv_vsetpvfn
5608 Works like C<vcatpvfn> but copies the text into the SV instead of
5615 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5617 sv_setpvn(sv, "", 0);
5618 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5622 =for apidoc sv_vcatpvfn
5624 Processes its arguments like C<vsprintf> and appends the formatted output
5625 to an SV. Uses an array of SVs if the C style variable argument list is
5626 missing (NULL). When running with taint checks enabled, indicates via
5627 C<maybe_tainted> if results are untrustworthy (often due to the use of
5634 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5642 static char nullstr[] = "(null)";
5645 /* no matter what, this is a string now */
5646 (void)SvPV_force(sv, origlen);
5648 /* special-case "", "%s", and "%_" */
5651 if (patlen == 2 && pat[0] == '%') {
5655 char *s = va_arg(*args, char*);
5656 sv_catpv(sv, s ? s : nullstr);
5658 else if (svix < svmax) {
5659 sv_catsv(sv, *svargs);
5660 if (DO_UTF8(*svargs))
5666 argsv = va_arg(*args, SV*);
5667 sv_catsv(sv, argsv);
5672 /* See comment on '_' below */
5677 patend = (char*)pat + patlen;
5678 for (p = (char*)pat; p < patend; p = q) {
5686 bool has_precis = FALSE;
5688 bool is_utf = FALSE;
5692 STRLEN esignlen = 0;
5694 char *eptr = Nullch;
5696 /* Times 4: a decimal digit takes more than 3 binary digits.
5697 * NV_DIG: mantissa takes than many decimal digits.
5698 * Plus 32: Playing safe. */
5699 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5700 /* large enough for "%#.#f" --chip */
5701 /* what about long double NVs? --jhi */
5712 for (q = p; q < patend && *q != '%'; ++q) ;
5714 sv_catpvn(sv, p, q - p);
5752 case '1': case '2': case '3':
5753 case '4': case '5': case '6':
5754 case '7': case '8': case '9':
5757 width = width * 10 + (*q++ - '0');
5762 i = va_arg(*args, int);
5764 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5766 width = (i < 0) ? -i : i;
5777 i = va_arg(*args, int);
5779 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5780 precis = (i < 0) ? 0 : i;
5786 precis = precis * 10 + (*q++ - '0');
5803 if (*(q + 1) == 'l') { /* lld */
5830 uv = va_arg(*args, int);
5832 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5833 if (uv >= 128 && PL_bigchar && !IN_BYTE) {
5834 eptr = (char*)utf8buf;
5835 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
5847 eptr = va_arg(*args, char*);
5849 #ifdef MACOS_TRADITIONAL
5850 /* On MacOS, %#s format is used for Pascal strings */
5855 elen = strlen(eptr);
5858 elen = sizeof nullstr - 1;
5861 else if (svix < svmax) {
5862 argsv = svargs[svix++];
5863 eptr = SvPVx(argsv, elen);
5864 if (DO_UTF8(argsv)) {
5865 if (has_precis && precis < elen) {
5867 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
5870 if (width) { /* fudge width (can't fudge elen) */
5871 width += elen - sv_len_utf8(argsv);
5880 * The "%_" hack might have to be changed someday,
5881 * if ISO or ANSI decide to use '_' for something.
5882 * So we keep it hidden from users' code.
5886 argsv = va_arg(*args,SV*);
5887 eptr = SvPVx(argsv, elen);
5892 if (has_precis && elen > precis)
5900 uv = PTR2UV(va_arg(*args, void*));
5902 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5917 case 'h': iv = (short)va_arg(*args, int); break;
5918 default: iv = va_arg(*args, int); break;
5919 case 'l': iv = va_arg(*args, long); break;
5920 case 'V': iv = va_arg(*args, IV); break;
5922 case 'q': iv = va_arg(*args, Quad_t); break;
5927 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5929 case 'h': iv = (short)iv; break;
5930 default: iv = (int)iv; break;
5931 case 'l': iv = (long)iv; break;
5934 case 'q': iv = (Quad_t)iv; break;
5941 esignbuf[esignlen++] = plus;
5945 esignbuf[esignlen++] = '-';
5983 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
5984 default: uv = va_arg(*args, unsigned); break;
5985 case 'l': uv = va_arg(*args, unsigned long); break;
5986 case 'V': uv = va_arg(*args, UV); break;
5988 case 'q': uv = va_arg(*args, Quad_t); break;
5993 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
5995 case 'h': uv = (unsigned short)uv; break;
5996 default: uv = (unsigned)uv; break;
5997 case 'l': uv = (unsigned long)uv; break;
6000 case 'q': uv = (Quad_t)uv; break;
6006 eptr = ebuf + sizeof ebuf;
6012 p = (char*)((c == 'X')
6013 ? "0123456789ABCDEF" : "0123456789abcdef");
6019 esignbuf[esignlen++] = '0';
6020 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6026 *--eptr = '0' + dig;
6028 if (alt && *eptr != '0')
6034 *--eptr = '0' + dig;
6037 esignbuf[esignlen++] = '0';
6038 esignbuf[esignlen++] = 'b';
6041 default: /* it had better be ten or less */
6042 #if defined(PERL_Y2KWARN)
6043 if (ckWARN(WARN_MISC)) {
6045 char *s = SvPV(sv,n);
6046 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6047 && (n == 2 || !isDIGIT(s[n-3])))
6049 Perl_warner(aTHX_ WARN_MISC,
6050 "Possible Y2K bug: %%%c %s",
6051 c, "format string following '19'");
6057 *--eptr = '0' + dig;
6058 } while (uv /= base);
6061 elen = (ebuf + sizeof ebuf) - eptr;
6064 zeros = precis - elen;
6065 else if (precis == 0 && elen == 1 && *eptr == '0')
6070 /* FLOATING POINT */
6073 c = 'f'; /* maybe %F isn't supported here */
6079 /* This is evil, but floating point is even more evil */
6082 nv = va_arg(*args, NV);
6084 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6087 if (c != 'e' && c != 'E') {
6089 (void)frexp(nv, &i);
6090 if (i == PERL_INT_MIN)
6091 Perl_die(aTHX_ "panic: frexp");
6093 need = BIT_DIGITS(i);
6095 need += has_precis ? precis : 6; /* known default */
6099 need += 20; /* fudge factor */
6100 if (PL_efloatsize < need) {
6101 Safefree(PL_efloatbuf);
6102 PL_efloatsize = need + 20; /* more fudge */
6103 New(906, PL_efloatbuf, PL_efloatsize, char);
6104 PL_efloatbuf[0] = '\0';
6107 eptr = ebuf + sizeof ebuf;
6110 #ifdef USE_LONG_DOUBLE
6112 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
6113 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
6118 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6123 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6136 RESTORE_NUMERIC_STANDARD();
6137 (void)sprintf(PL_efloatbuf, eptr, nv);
6138 RESTORE_NUMERIC_LOCAL();
6141 eptr = PL_efloatbuf;
6142 elen = strlen(PL_efloatbuf);
6148 i = SvCUR(sv) - origlen;
6151 case 'h': *(va_arg(*args, short*)) = i; break;
6152 default: *(va_arg(*args, int*)) = i; break;
6153 case 'l': *(va_arg(*args, long*)) = i; break;
6154 case 'V': *(va_arg(*args, IV*)) = i; break;
6156 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6160 else if (svix < svmax)
6161 sv_setuv(svargs[svix++], (UV)i);
6162 continue; /* not "break" */
6168 if (!args && ckWARN(WARN_PRINTF) &&
6169 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6170 SV *msg = sv_newmortal();
6171 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6172 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6175 Perl_sv_catpvf(aTHX_ msg,
6176 "\"%%%c\"", c & 0xFF);
6178 Perl_sv_catpvf(aTHX_ msg,
6179 "\"%%\\%03"UVof"\"",
6182 sv_catpv(msg, "end of string");
6183 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6186 /* output mangled stuff ... */
6192 /* ... right here, because formatting flags should not apply */
6193 SvGROW(sv, SvCUR(sv) + elen + 1);
6195 memcpy(p, eptr, elen);
6198 SvCUR(sv) = p - SvPVX(sv);
6199 continue; /* not "break" */
6202 have = esignlen + zeros + elen;
6203 need = (have > width ? have : width);
6206 SvGROW(sv, SvCUR(sv) + need + 1);
6208 if (esignlen && fill == '0') {
6209 for (i = 0; i < esignlen; i++)
6213 memset(p, fill, gap);
6216 if (esignlen && fill != '0') {
6217 for (i = 0; i < esignlen; i++)
6221 for (i = zeros; i; i--)
6225 memcpy(p, eptr, elen);
6229 memset(p, ' ', gap);
6235 SvCUR(sv) = p - SvPVX(sv);
6239 #if defined(USE_ITHREADS)
6241 #if defined(USE_THREADS)
6242 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6245 #ifndef OpREFCNT_inc
6246 # define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop)
6249 #ifndef GpREFCNT_inc
6250 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6254 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6255 #define av_dup(s) (AV*)sv_dup((SV*)s)
6256 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6257 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6258 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6259 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6260 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6261 #define io_dup(s) (IO*)sv_dup((SV*)s)
6262 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6263 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6264 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6265 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6266 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6269 Perl_re_dup(pTHX_ REGEXP *r)
6271 /* XXX fix when pmop->op_pmregexp becomes shared */
6272 return ReREFCNT_inc(r);
6276 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6280 return (PerlIO*)NULL;
6282 /* look for it in the table first */
6283 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6287 /* create anew and remember what it is */
6288 ret = PerlIO_fdupopen(fp);
6289 ptr_table_store(PL_ptr_table, fp, ret);
6294 Perl_dirp_dup(pTHX_ DIR *dp)
6303 Perl_gp_dup(pTHX_ GP *gp)
6308 /* look for it in the table first */
6309 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6313 /* create anew and remember what it is */
6314 Newz(0, ret, 1, GP);
6315 ptr_table_store(PL_ptr_table, gp, ret);
6318 ret->gp_refcnt = 0; /* must be before any other dups! */
6319 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6320 ret->gp_io = io_dup_inc(gp->gp_io);
6321 ret->gp_form = cv_dup_inc(gp->gp_form);
6322 ret->gp_av = av_dup_inc(gp->gp_av);
6323 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6324 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6325 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6326 ret->gp_cvgen = gp->gp_cvgen;
6327 ret->gp_flags = gp->gp_flags;
6328 ret->gp_line = gp->gp_line;
6329 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6334 Perl_mg_dup(pTHX_ MAGIC *mg)
6336 MAGIC *mgret = (MAGIC*)NULL;
6339 return (MAGIC*)NULL;
6340 /* look for it in the table first */
6341 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6345 for (; mg; mg = mg->mg_moremagic) {
6347 Newz(0, nmg, 1, MAGIC);
6351 mgprev->mg_moremagic = nmg;
6352 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6353 nmg->mg_private = mg->mg_private;
6354 nmg->mg_type = mg->mg_type;
6355 nmg->mg_flags = mg->mg_flags;
6356 if (mg->mg_type == 'r') {
6357 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6360 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6361 ? sv_dup_inc(mg->mg_obj)
6362 : sv_dup(mg->mg_obj);
6364 nmg->mg_len = mg->mg_len;
6365 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6366 if (mg->mg_ptr && mg->mg_type != 'g') {
6367 if (mg->mg_len >= 0) {
6368 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6369 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6370 AMT *amtp = (AMT*)mg->mg_ptr;
6371 AMT *namtp = (AMT*)nmg->mg_ptr;
6373 for (i = 1; i < NofAMmeth; i++) {
6374 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6378 else if (mg->mg_len == HEf_SVKEY)
6379 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6387 Perl_ptr_table_new(pTHX)
6390 Newz(0, tbl, 1, PTR_TBL_t);
6393 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6398 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6400 PTR_TBL_ENT_t *tblent;
6401 UV hash = PTR2UV(sv);
6403 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6404 for (; tblent; tblent = tblent->next) {
6405 if (tblent->oldval == sv)
6406 return tblent->newval;
6412 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6414 PTR_TBL_ENT_t *tblent, **otblent;
6415 /* XXX this may be pessimal on platforms where pointers aren't good
6416 * hash values e.g. if they grow faster in the most significant
6418 UV hash = PTR2UV(oldv);
6422 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6423 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6424 if (tblent->oldval == oldv) {
6425 tblent->newval = newv;
6430 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6431 tblent->oldval = oldv;
6432 tblent->newval = newv;
6433 tblent->next = *otblent;
6436 if (i && tbl->tbl_items > tbl->tbl_max)
6437 ptr_table_split(tbl);
6441 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6443 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6444 UV oldsize = tbl->tbl_max + 1;
6445 UV newsize = oldsize * 2;
6448 Renew(ary, newsize, PTR_TBL_ENT_t*);
6449 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6450 tbl->tbl_max = --newsize;
6452 for (i=0; i < oldsize; i++, ary++) {
6453 PTR_TBL_ENT_t **curentp, **entp, *ent;
6456 curentp = ary + oldsize;
6457 for (entp = ary, ent = *ary; ent; ent = *entp) {
6458 if ((newsize & PTR2UV(ent->oldval)) != i) {
6460 ent->next = *curentp;
6475 Perl_sv_dup(pTHX_ SV *sstr)
6482 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6484 /* look for it in the table first */
6485 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6489 /* create anew and remember what it is */
6491 ptr_table_store(PL_ptr_table, sstr, dstr);
6494 SvFLAGS(dstr) = SvFLAGS(sstr);
6495 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6496 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6499 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6500 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6501 PL_watch_pvx, SvPVX(sstr));
6504 switch (SvTYPE(sstr)) {
6509 SvANY(dstr) = new_XIV();
6510 SvIVX(dstr) = SvIVX(sstr);
6513 SvANY(dstr) = new_XNV();
6514 SvNVX(dstr) = SvNVX(sstr);
6517 SvANY(dstr) = new_XRV();
6518 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6521 SvANY(dstr) = new_XPV();
6522 SvCUR(dstr) = SvCUR(sstr);
6523 SvLEN(dstr) = SvLEN(sstr);
6525 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6526 else if (SvPVX(sstr) && SvLEN(sstr))
6527 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6529 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6532 SvANY(dstr) = new_XPVIV();
6533 SvCUR(dstr) = SvCUR(sstr);
6534 SvLEN(dstr) = SvLEN(sstr);
6535 SvIVX(dstr) = SvIVX(sstr);
6537 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6538 else if (SvPVX(sstr) && SvLEN(sstr))
6539 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6541 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6544 SvANY(dstr) = new_XPVNV();
6545 SvCUR(dstr) = SvCUR(sstr);
6546 SvLEN(dstr) = SvLEN(sstr);
6547 SvIVX(dstr) = SvIVX(sstr);
6548 SvNVX(dstr) = SvNVX(sstr);
6550 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6551 else if (SvPVX(sstr) && SvLEN(sstr))
6552 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6554 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6557 SvANY(dstr) = new_XPVMG();
6558 SvCUR(dstr) = SvCUR(sstr);
6559 SvLEN(dstr) = SvLEN(sstr);
6560 SvIVX(dstr) = SvIVX(sstr);
6561 SvNVX(dstr) = SvNVX(sstr);
6562 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6563 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6565 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6566 else if (SvPVX(sstr) && SvLEN(sstr))
6567 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6569 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6572 SvANY(dstr) = new_XPVBM();
6573 SvCUR(dstr) = SvCUR(sstr);
6574 SvLEN(dstr) = SvLEN(sstr);
6575 SvIVX(dstr) = SvIVX(sstr);
6576 SvNVX(dstr) = SvNVX(sstr);
6577 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6578 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6580 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6581 else if (SvPVX(sstr) && SvLEN(sstr))
6582 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6584 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6585 BmRARE(dstr) = BmRARE(sstr);
6586 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6587 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6590 SvANY(dstr) = new_XPVLV();
6591 SvCUR(dstr) = SvCUR(sstr);
6592 SvLEN(dstr) = SvLEN(sstr);
6593 SvIVX(dstr) = SvIVX(sstr);
6594 SvNVX(dstr) = SvNVX(sstr);
6595 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6596 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6598 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6599 else if (SvPVX(sstr) && SvLEN(sstr))
6600 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6602 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6603 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6604 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6605 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6606 LvTYPE(dstr) = LvTYPE(sstr);
6609 SvANY(dstr) = new_XPVGV();
6610 SvCUR(dstr) = SvCUR(sstr);
6611 SvLEN(dstr) = SvLEN(sstr);
6612 SvIVX(dstr) = SvIVX(sstr);
6613 SvNVX(dstr) = SvNVX(sstr);
6614 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6615 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6617 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6618 else if (SvPVX(sstr) && SvLEN(sstr))
6619 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6621 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6622 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6623 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6624 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6625 GvFLAGS(dstr) = GvFLAGS(sstr);
6626 GvGP(dstr) = gp_dup(GvGP(sstr));
6627 (void)GpREFCNT_inc(GvGP(dstr));
6630 SvANY(dstr) = new_XPVIO();
6631 SvCUR(dstr) = SvCUR(sstr);
6632 SvLEN(dstr) = SvLEN(sstr);
6633 SvIVX(dstr) = SvIVX(sstr);
6634 SvNVX(dstr) = SvNVX(sstr);
6635 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6636 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6638 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6639 else if (SvPVX(sstr) && SvLEN(sstr))
6640 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6642 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6643 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6644 if (IoOFP(sstr) == IoIFP(sstr))
6645 IoOFP(dstr) = IoIFP(dstr);
6647 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6648 /* PL_rsfp_filters entries have fake IoDIRP() */
6649 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6650 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6652 IoDIRP(dstr) = IoDIRP(sstr);
6653 IoLINES(dstr) = IoLINES(sstr);
6654 IoPAGE(dstr) = IoPAGE(sstr);
6655 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6656 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6657 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6658 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6659 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6660 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6661 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6662 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6663 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6664 IoTYPE(dstr) = IoTYPE(sstr);
6665 IoFLAGS(dstr) = IoFLAGS(sstr);
6668 SvANY(dstr) = new_XPVAV();
6669 SvCUR(dstr) = SvCUR(sstr);
6670 SvLEN(dstr) = SvLEN(sstr);
6671 SvIVX(dstr) = SvIVX(sstr);
6672 SvNVX(dstr) = SvNVX(sstr);
6673 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6674 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6675 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6676 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6677 if (AvARRAY((AV*)sstr)) {
6678 SV **dst_ary, **src_ary;
6679 SSize_t items = AvFILLp((AV*)sstr) + 1;
6681 src_ary = AvARRAY((AV*)sstr);
6682 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6683 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6684 SvPVX(dstr) = (char*)dst_ary;
6685 AvALLOC((AV*)dstr) = dst_ary;
6686 if (AvREAL((AV*)sstr)) {
6688 *dst_ary++ = sv_dup_inc(*src_ary++);
6692 *dst_ary++ = sv_dup(*src_ary++);
6694 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6695 while (items-- > 0) {
6696 *dst_ary++ = &PL_sv_undef;
6700 SvPVX(dstr) = Nullch;
6701 AvALLOC((AV*)dstr) = (SV**)NULL;
6705 SvANY(dstr) = new_XPVHV();
6706 SvCUR(dstr) = SvCUR(sstr);
6707 SvLEN(dstr) = SvLEN(sstr);
6708 SvIVX(dstr) = SvIVX(sstr);
6709 SvNVX(dstr) = SvNVX(sstr);
6710 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6711 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6712 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6713 if (HvARRAY((HV*)sstr)) {
6716 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6717 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6718 Newz(0, dxhv->xhv_array,
6719 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6720 while (i <= sxhv->xhv_max) {
6721 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6722 !!HvSHAREKEYS(sstr));
6725 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6728 SvPVX(dstr) = Nullch;
6729 HvEITER((HV*)dstr) = (HE*)NULL;
6731 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6732 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6735 SvANY(dstr) = new_XPVFM();
6736 FmLINES(dstr) = FmLINES(sstr);
6740 SvANY(dstr) = new_XPVCV();
6742 SvCUR(dstr) = SvCUR(sstr);
6743 SvLEN(dstr) = SvLEN(sstr);
6744 SvIVX(dstr) = SvIVX(sstr);
6745 SvNVX(dstr) = SvNVX(sstr);
6746 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6747 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6748 if (SvPVX(sstr) && SvLEN(sstr))
6749 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6751 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6752 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6753 CvSTART(dstr) = CvSTART(sstr);
6754 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6755 CvXSUB(dstr) = CvXSUB(sstr);
6756 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6757 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6758 CvDEPTH(dstr) = CvDEPTH(sstr);
6759 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6760 /* XXX padlists are real, but pretend to be not */
6761 AvREAL_on(CvPADLIST(sstr));
6762 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6763 AvREAL_off(CvPADLIST(sstr));
6764 AvREAL_off(CvPADLIST(dstr));
6767 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6768 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6769 CvFLAGS(dstr) = CvFLAGS(sstr);
6772 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6776 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6783 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6788 return (PERL_CONTEXT*)NULL;
6790 /* look for it in the table first */
6791 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6795 /* create anew and remember what it is */
6796 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6797 ptr_table_store(PL_ptr_table, cxs, ncxs);
6800 PERL_CONTEXT *cx = &cxs[ix];
6801 PERL_CONTEXT *ncx = &ncxs[ix];
6802 ncx->cx_type = cx->cx_type;
6803 if (CxTYPE(cx) == CXt_SUBST) {
6804 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6807 ncx->blk_oldsp = cx->blk_oldsp;
6808 ncx->blk_oldcop = cx->blk_oldcop;
6809 ncx->blk_oldretsp = cx->blk_oldretsp;
6810 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6811 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6812 ncx->blk_oldpm = cx->blk_oldpm;
6813 ncx->blk_gimme = cx->blk_gimme;
6814 switch (CxTYPE(cx)) {
6816 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6817 ? cv_dup_inc(cx->blk_sub.cv)
6818 : cv_dup(cx->blk_sub.cv));
6819 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6820 ? av_dup_inc(cx->blk_sub.argarray)
6822 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6823 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6824 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6825 ncx->blk_sub.lval = cx->blk_sub.lval;
6828 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6829 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6830 ncx->blk_eval.old_name = SAVEPV(cx->blk_eval.old_name);
6831 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6832 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
6835 ncx->blk_loop.label = cx->blk_loop.label;
6836 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
6837 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
6838 ncx->blk_loop.next_op = cx->blk_loop.next_op;
6839 ncx->blk_loop.last_op = cx->blk_loop.last_op;
6840 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
6841 ? cx->blk_loop.iterdata
6842 : gv_dup((GV*)cx->blk_loop.iterdata));
6843 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
6844 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
6845 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
6846 ncx->blk_loop.iterix = cx->blk_loop.iterix;
6847 ncx->blk_loop.itermax = cx->blk_loop.itermax;
6850 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
6851 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
6852 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
6853 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6866 Perl_si_dup(pTHX_ PERL_SI *si)
6871 return (PERL_SI*)NULL;
6873 /* look for it in the table first */
6874 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6878 /* create anew and remember what it is */
6879 Newz(56, nsi, 1, PERL_SI);
6880 ptr_table_store(PL_ptr_table, si, nsi);
6882 nsi->si_stack = av_dup_inc(si->si_stack);
6883 nsi->si_cxix = si->si_cxix;
6884 nsi->si_cxmax = si->si_cxmax;
6885 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6886 nsi->si_type = si->si_type;
6887 nsi->si_prev = si_dup(si->si_prev);
6888 nsi->si_next = si_dup(si->si_next);
6889 nsi->si_markoff = si->si_markoff;
6894 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
6895 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
6896 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
6897 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
6898 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
6899 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
6900 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
6901 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
6902 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
6903 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
6904 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
6905 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
6908 #define pv_dup_inc(p) SAVEPV(p)
6909 #define pv_dup(p) SAVEPV(p)
6910 #define svp_dup_inc(p,pp) any_dup(p,pp)
6913 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
6920 /* look for it in the table first */
6921 ret = ptr_table_fetch(PL_ptr_table, v);
6925 /* see if it is part of the interpreter structure */
6926 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
6927 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
6935 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
6937 ANY *ss = proto_perl->Tsavestack;
6938 I32 ix = proto_perl->Tsavestack_ix;
6939 I32 max = proto_perl->Tsavestack_max;
6952 void (*dptr) (void*);
6953 void (*dxptr) (pTHXo_ void*);
6955 Newz(54, nss, max, ANY);
6961 case SAVEt_ITEM: /* normal string */
6962 sv = (SV*)POPPTR(ss,ix);
6963 TOPPTR(nss,ix) = sv_dup_inc(sv);
6964 sv = (SV*)POPPTR(ss,ix);
6965 TOPPTR(nss,ix) = sv_dup_inc(sv);
6967 case SAVEt_SV: /* scalar reference */
6968 sv = (SV*)POPPTR(ss,ix);
6969 TOPPTR(nss,ix) = sv_dup_inc(sv);
6970 gv = (GV*)POPPTR(ss,ix);
6971 TOPPTR(nss,ix) = gv_dup_inc(gv);
6973 case SAVEt_GENERIC_SVREF: /* generic sv */
6974 case SAVEt_SVREF: /* scalar reference */
6975 sv = (SV*)POPPTR(ss,ix);
6976 TOPPTR(nss,ix) = sv_dup_inc(sv);
6977 ptr = POPPTR(ss,ix);
6978 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
6980 case SAVEt_AV: /* array reference */
6981 av = (AV*)POPPTR(ss,ix);
6982 TOPPTR(nss,ix) = av_dup_inc(av);
6983 gv = (GV*)POPPTR(ss,ix);
6984 TOPPTR(nss,ix) = gv_dup(gv);
6986 case SAVEt_HV: /* hash reference */
6987 hv = (HV*)POPPTR(ss,ix);
6988 TOPPTR(nss,ix) = hv_dup_inc(hv);
6989 gv = (GV*)POPPTR(ss,ix);
6990 TOPPTR(nss,ix) = gv_dup(gv);
6992 case SAVEt_INT: /* int reference */
6993 ptr = POPPTR(ss,ix);
6994 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
6995 intval = (int)POPINT(ss,ix);
6996 TOPINT(nss,ix) = intval;
6998 case SAVEt_LONG: /* long reference */
6999 ptr = POPPTR(ss,ix);
7000 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7001 longval = (long)POPLONG(ss,ix);
7002 TOPLONG(nss,ix) = longval;
7004 case SAVEt_I32: /* I32 reference */
7005 case SAVEt_I16: /* I16 reference */
7006 case SAVEt_I8: /* I8 reference */
7007 ptr = POPPTR(ss,ix);
7008 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7012 case SAVEt_IV: /* IV reference */
7013 ptr = POPPTR(ss,ix);
7014 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7018 case SAVEt_SPTR: /* SV* reference */
7019 ptr = POPPTR(ss,ix);
7020 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7021 sv = (SV*)POPPTR(ss,ix);
7022 TOPPTR(nss,ix) = sv_dup(sv);
7024 case SAVEt_VPTR: /* random* reference */
7025 ptr = POPPTR(ss,ix);
7026 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7027 ptr = POPPTR(ss,ix);
7028 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7030 case SAVEt_PPTR: /* char* reference */
7031 ptr = POPPTR(ss,ix);
7032 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7033 c = (char*)POPPTR(ss,ix);
7034 TOPPTR(nss,ix) = pv_dup(c);
7036 case SAVEt_HPTR: /* HV* reference */
7037 ptr = POPPTR(ss,ix);
7038 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7039 hv = (HV*)POPPTR(ss,ix);
7040 TOPPTR(nss,ix) = hv_dup(hv);
7042 case SAVEt_APTR: /* AV* reference */
7043 ptr = POPPTR(ss,ix);
7044 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7045 av = (AV*)POPPTR(ss,ix);
7046 TOPPTR(nss,ix) = av_dup(av);
7049 gv = (GV*)POPPTR(ss,ix);
7050 TOPPTR(nss,ix) = gv_dup(gv);
7052 case SAVEt_GP: /* scalar reference */
7053 gp = (GP*)POPPTR(ss,ix);
7054 TOPPTR(nss,ix) = gp = gp_dup(gp);
7055 (void)GpREFCNT_inc(gp);
7056 gv = (GV*)POPPTR(ss,ix);
7057 TOPPTR(nss,ix) = gv_dup_inc(c);
7058 c = (char*)POPPTR(ss,ix);
7059 TOPPTR(nss,ix) = pv_dup(c);
7066 sv = (SV*)POPPTR(ss,ix);
7067 TOPPTR(nss,ix) = sv_dup_inc(sv);
7070 ptr = POPPTR(ss,ix);
7071 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7072 /* these are assumed to be refcounted properly */
7073 switch (((OP*)ptr)->op_type) {
7080 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7083 TOPPTR(nss,ix) = Nullop;
7088 TOPPTR(nss,ix) = Nullop;
7091 c = (char*)POPPTR(ss,ix);
7092 TOPPTR(nss,ix) = pv_dup_inc(c);
7095 longval = POPLONG(ss,ix);
7096 TOPLONG(nss,ix) = longval;
7099 hv = (HV*)POPPTR(ss,ix);
7100 TOPPTR(nss,ix) = hv_dup_inc(hv);
7101 c = (char*)POPPTR(ss,ix);
7102 TOPPTR(nss,ix) = pv_dup_inc(c);
7106 case SAVEt_DESTRUCTOR:
7107 ptr = POPPTR(ss,ix);
7108 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7109 dptr = POPDPTR(ss,ix);
7110 TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
7112 case SAVEt_DESTRUCTOR_X:
7113 ptr = POPPTR(ss,ix);
7114 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7115 dxptr = POPDXPTR(ss,ix);
7116 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
7118 case SAVEt_REGCONTEXT:
7124 case SAVEt_STACK_POS: /* Position on Perl stack */
7128 case SAVEt_AELEM: /* array element */
7129 sv = (SV*)POPPTR(ss,ix);
7130 TOPPTR(nss,ix) = sv_dup_inc(sv);
7133 av = (AV*)POPPTR(ss,ix);
7134 TOPPTR(nss,ix) = av_dup_inc(av);
7136 case SAVEt_HELEM: /* hash element */
7137 sv = (SV*)POPPTR(ss,ix);
7138 TOPPTR(nss,ix) = sv_dup_inc(sv);
7139 sv = (SV*)POPPTR(ss,ix);
7140 TOPPTR(nss,ix) = sv_dup_inc(sv);
7141 hv = (HV*)POPPTR(ss,ix);
7142 TOPPTR(nss,ix) = hv_dup_inc(hv);
7145 ptr = POPPTR(ss,ix);
7146 TOPPTR(nss,ix) = ptr;
7153 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7165 perl_clone(PerlInterpreter *proto_perl, UV flags)
7168 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7171 #ifdef PERL_IMPLICIT_SYS
7172 return perl_clone_using(proto_perl, flags,
7174 proto_perl->IMemShared,
7175 proto_perl->IMemParse,
7185 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7186 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7187 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7188 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7189 struct IPerlDir* ipD, struct IPerlSock* ipS,
7190 struct IPerlProc* ipP)
7192 /* XXX many of the string copies here can be optimized if they're
7193 * constants; they need to be allocated as common memory and just
7194 * their pointers copied. */
7200 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7202 PERL_SET_INTERP(pPerl);
7203 # else /* !PERL_OBJECT */
7204 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7205 PERL_SET_INTERP(my_perl);
7208 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7213 # else /* !DEBUGGING */
7214 Zero(my_perl, 1, PerlInterpreter);
7215 # endif /* DEBUGGING */
7219 PL_MemShared = ipMS;
7227 # endif /* PERL_OBJECT */
7228 #else /* !PERL_IMPLICIT_SYS */
7232 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7233 PERL_SET_INTERP(my_perl);
7236 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7241 # else /* !DEBUGGING */
7242 Zero(my_perl, 1, PerlInterpreter);
7243 # endif /* DEBUGGING */
7244 #endif /* PERL_IMPLICIT_SYS */
7247 PL_xiv_arenaroot = NULL;
7252 PL_xpviv_root = NULL;
7253 PL_xpvnv_root = NULL;
7254 PL_xpvcv_root = NULL;
7255 PL_xpvav_root = NULL;
7256 PL_xpvhv_root = NULL;
7257 PL_xpvmg_root = NULL;
7258 PL_xpvlv_root = NULL;
7259 PL_xpvbm_root = NULL;
7261 PL_nice_chunk = NULL;
7262 PL_nice_chunk_size = 0;
7265 PL_sv_root = Nullsv;
7266 PL_sv_arenaroot = Nullsv;
7268 PL_debug = proto_perl->Idebug;
7270 /* create SV map for pointer relocation */
7271 PL_ptr_table = ptr_table_new();
7273 /* initialize these special pointers as early as possible */
7274 SvANY(&PL_sv_undef) = NULL;
7275 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7276 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7277 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7280 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7282 SvANY(&PL_sv_no) = new_XPVNV();
7284 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7285 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7286 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7287 SvCUR(&PL_sv_no) = 0;
7288 SvLEN(&PL_sv_no) = 1;
7289 SvNVX(&PL_sv_no) = 0;
7290 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7293 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7295 SvANY(&PL_sv_yes) = new_XPVNV();
7297 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7298 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7299 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7300 SvCUR(&PL_sv_yes) = 1;
7301 SvLEN(&PL_sv_yes) = 2;
7302 SvNVX(&PL_sv_yes) = 1;
7303 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7305 /* create shared string table */
7306 PL_strtab = newHV();
7307 HvSHAREKEYS_off(PL_strtab);
7308 hv_ksplit(PL_strtab, 512);
7309 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7311 PL_compiling = proto_perl->Icompiling;
7312 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7313 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7314 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7315 if (!specialWARN(PL_compiling.cop_warnings))
7316 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7317 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7319 /* pseudo environmental stuff */
7320 PL_origargc = proto_perl->Iorigargc;
7322 New(0, PL_origargv, i+1, char*);
7323 PL_origargv[i] = '\0';
7325 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7327 PL_envgv = gv_dup(proto_perl->Ienvgv);
7328 PL_incgv = gv_dup(proto_perl->Iincgv);
7329 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7330 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7331 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7332 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7335 PL_minus_c = proto_perl->Iminus_c;
7336 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7337 PL_localpatches = proto_perl->Ilocalpatches;
7338 PL_splitstr = proto_perl->Isplitstr;
7339 PL_preprocess = proto_perl->Ipreprocess;
7340 PL_minus_n = proto_perl->Iminus_n;
7341 PL_minus_p = proto_perl->Iminus_p;
7342 PL_minus_l = proto_perl->Iminus_l;
7343 PL_minus_a = proto_perl->Iminus_a;
7344 PL_minus_F = proto_perl->Iminus_F;
7345 PL_doswitches = proto_perl->Idoswitches;
7346 PL_dowarn = proto_perl->Idowarn;
7347 PL_doextract = proto_perl->Idoextract;
7348 PL_sawampersand = proto_perl->Isawampersand;
7349 PL_unsafe = proto_perl->Iunsafe;
7350 PL_inplace = SAVEPV(proto_perl->Iinplace);
7351 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7352 PL_perldb = proto_perl->Iperldb;
7353 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7355 /* magical thingies */
7356 /* XXX time(&PL_basetime) when asked for? */
7357 PL_basetime = proto_perl->Ibasetime;
7358 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7360 PL_maxsysfd = proto_perl->Imaxsysfd;
7361 PL_multiline = proto_perl->Imultiline;
7362 PL_statusvalue = proto_perl->Istatusvalue;
7364 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7367 /* shortcuts to various I/O objects */
7368 PL_stdingv = gv_dup(proto_perl->Istdingv);
7369 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7370 PL_defgv = gv_dup(proto_perl->Idefgv);
7371 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7372 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7373 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7375 /* shortcuts to regexp stuff */
7376 PL_replgv = gv_dup(proto_perl->Ireplgv);
7378 /* shortcuts to misc objects */
7379 PL_errgv = gv_dup(proto_perl->Ierrgv);
7381 /* shortcuts to debugging objects */
7382 PL_DBgv = gv_dup(proto_perl->IDBgv);
7383 PL_DBline = gv_dup(proto_perl->IDBline);
7384 PL_DBsub = gv_dup(proto_perl->IDBsub);
7385 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7386 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7387 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7388 PL_lineary = av_dup(proto_perl->Ilineary);
7389 PL_dbargs = av_dup(proto_perl->Idbargs);
7392 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7393 PL_curstash = hv_dup(proto_perl->Tcurstash);
7394 PL_debstash = hv_dup(proto_perl->Idebstash);
7395 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7396 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7398 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7399 PL_endav = av_dup_inc(proto_perl->Iendav);
7400 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7401 PL_initav = av_dup_inc(proto_perl->Iinitav);
7403 PL_sub_generation = proto_perl->Isub_generation;
7405 /* funky return mechanisms */
7406 PL_forkprocess = proto_perl->Iforkprocess;
7408 /* subprocess state */
7409 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7411 /* internal state */
7412 PL_tainting = proto_perl->Itainting;
7413 PL_maxo = proto_perl->Imaxo;
7414 if (proto_perl->Iop_mask)
7415 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7417 PL_op_mask = Nullch;
7419 /* current interpreter roots */
7420 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7421 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7422 PL_main_start = proto_perl->Imain_start;
7423 PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root);
7424 PL_eval_start = proto_perl->Ieval_start;
7426 /* runtime control stuff */
7427 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7428 PL_copline = proto_perl->Icopline;
7430 PL_filemode = proto_perl->Ifilemode;
7431 PL_lastfd = proto_perl->Ilastfd;
7432 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7435 PL_gensym = proto_perl->Igensym;
7436 PL_preambled = proto_perl->Ipreambled;
7437 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7438 PL_laststatval = proto_perl->Ilaststatval;
7439 PL_laststype = proto_perl->Ilaststype;
7440 PL_mess_sv = Nullsv;
7442 PL_orslen = proto_perl->Iorslen;
7443 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7444 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7446 /* interpreter atexit processing */
7447 PL_exitlistlen = proto_perl->Iexitlistlen;
7448 if (PL_exitlistlen) {
7449 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7450 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7453 PL_exitlist = (PerlExitListEntry*)NULL;
7454 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7456 PL_profiledata = NULL;
7457 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7458 /* PL_rsfp_filters entries have fake IoDIRP() */
7459 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7461 PL_compcv = cv_dup(proto_perl->Icompcv);
7462 PL_comppad = av_dup(proto_perl->Icomppad);
7463 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7464 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7465 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7466 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7467 proto_perl->Tcurpad);
7469 #ifdef HAVE_INTERP_INTERN
7470 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7473 /* more statics moved here */
7474 PL_generation = proto_perl->Igeneration;
7475 PL_DBcv = cv_dup(proto_perl->IDBcv);
7477 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7478 PL_in_clean_all = proto_perl->Iin_clean_all;
7480 PL_uid = proto_perl->Iuid;
7481 PL_euid = proto_perl->Ieuid;
7482 PL_gid = proto_perl->Igid;
7483 PL_egid = proto_perl->Iegid;
7484 PL_nomemok = proto_perl->Inomemok;
7485 PL_an = proto_perl->Ian;
7486 PL_cop_seqmax = proto_perl->Icop_seqmax;
7487 PL_op_seqmax = proto_perl->Iop_seqmax;
7488 PL_evalseq = proto_perl->Ievalseq;
7489 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7490 PL_origalen = proto_perl->Iorigalen;
7491 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7492 PL_osname = SAVEPV(proto_perl->Iosname);
7493 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7494 PL_sighandlerp = proto_perl->Isighandlerp;
7497 PL_runops = proto_perl->Irunops;
7499 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7502 PL_cshlen = proto_perl->Icshlen;
7503 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7506 PL_lex_state = proto_perl->Ilex_state;
7507 PL_lex_defer = proto_perl->Ilex_defer;
7508 PL_lex_expect = proto_perl->Ilex_expect;
7509 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7510 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7511 PL_lex_starts = proto_perl->Ilex_starts;
7512 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7513 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7514 PL_lex_op = proto_perl->Ilex_op;
7515 PL_lex_inpat = proto_perl->Ilex_inpat;
7516 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7517 PL_lex_brackets = proto_perl->Ilex_brackets;
7518 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7519 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7520 PL_lex_casemods = proto_perl->Ilex_casemods;
7521 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7522 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7524 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7525 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7526 PL_nexttoke = proto_perl->Inexttoke;
7528 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7529 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7530 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7531 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7532 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7533 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7534 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7535 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7536 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7537 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7538 PL_pending_ident = proto_perl->Ipending_ident;
7539 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7541 PL_expect = proto_perl->Iexpect;
7543 PL_multi_start = proto_perl->Imulti_start;
7544 PL_multi_end = proto_perl->Imulti_end;
7545 PL_multi_open = proto_perl->Imulti_open;
7546 PL_multi_close = proto_perl->Imulti_close;
7548 PL_error_count = proto_perl->Ierror_count;
7549 PL_subline = proto_perl->Isubline;
7550 PL_subname = sv_dup_inc(proto_perl->Isubname);
7552 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7553 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7554 PL_padix = proto_perl->Ipadix;
7555 PL_padix_floor = proto_perl->Ipadix_floor;
7556 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7558 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7559 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7560 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7561 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7562 PL_last_lop_op = proto_perl->Ilast_lop_op;
7563 PL_in_my = proto_perl->Iin_my;
7564 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7566 PL_cryptseen = proto_perl->Icryptseen;
7569 PL_hints = proto_perl->Ihints;
7571 PL_amagic_generation = proto_perl->Iamagic_generation;
7573 #ifdef USE_LOCALE_COLLATE
7574 PL_collation_ix = proto_perl->Icollation_ix;
7575 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7576 PL_collation_standard = proto_perl->Icollation_standard;
7577 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7578 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7579 #endif /* USE_LOCALE_COLLATE */
7581 #ifdef USE_LOCALE_NUMERIC
7582 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7583 PL_numeric_standard = proto_perl->Inumeric_standard;
7584 PL_numeric_local = proto_perl->Inumeric_local;
7585 PL_numeric_radix = proto_perl->Inumeric_radix;
7586 #endif /* !USE_LOCALE_NUMERIC */
7588 /* utf8 character classes */
7589 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7590 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7591 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7592 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7593 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7594 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7595 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7596 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7597 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7598 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7599 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7600 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7601 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7602 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7603 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7604 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7605 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7608 PL_last_swash_hv = Nullhv; /* reinits on demand */
7609 PL_last_swash_klen = 0;
7610 PL_last_swash_key[0]= '\0';
7611 PL_last_swash_tmps = (U8*)NULL;
7612 PL_last_swash_slen = 0;
7614 /* perly.c globals */
7615 PL_yydebug = proto_perl->Iyydebug;
7616 PL_yynerrs = proto_perl->Iyynerrs;
7617 PL_yyerrflag = proto_perl->Iyyerrflag;
7618 PL_yychar = proto_perl->Iyychar;
7619 PL_yyval = proto_perl->Iyyval;
7620 PL_yylval = proto_perl->Iyylval;
7622 PL_glob_index = proto_perl->Iglob_index;
7623 PL_srand_called = proto_perl->Isrand_called;
7624 PL_uudmap['M'] = 0; /* reinits on demand */
7625 PL_bitcount = Nullch; /* reinits on demand */
7627 if (proto_perl->Ipsig_ptr) {
7628 int sig_num[] = { SIG_NUM };
7629 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7630 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7631 for (i = 1; PL_sig_name[i]; i++) {
7632 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7633 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7637 PL_psig_ptr = (SV**)NULL;
7638 PL_psig_name = (SV**)NULL;
7641 /* thrdvar.h stuff */
7644 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7645 PL_tmps_ix = proto_perl->Ttmps_ix;
7646 PL_tmps_max = proto_perl->Ttmps_max;
7647 PL_tmps_floor = proto_perl->Ttmps_floor;
7648 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7650 while (i <= PL_tmps_ix) {
7651 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7655 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7656 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7657 Newz(54, PL_markstack, i, I32);
7658 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7659 - proto_perl->Tmarkstack);
7660 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7661 - proto_perl->Tmarkstack);
7662 Copy(proto_perl->Tmarkstack, PL_markstack,
7663 PL_markstack_ptr - PL_markstack + 1, I32);
7665 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7666 * NOTE: unlike the others! */
7667 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7668 PL_scopestack_max = proto_perl->Tscopestack_max;
7669 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7670 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7672 /* next push_return() sets PL_retstack[PL_retstack_ix]
7673 * NOTE: unlike the others! */
7674 PL_retstack_ix = proto_perl->Tretstack_ix;
7675 PL_retstack_max = proto_perl->Tretstack_max;
7676 Newz(54, PL_retstack, PL_retstack_max, OP*);
7677 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7679 /* NOTE: si_dup() looks at PL_markstack */
7680 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7682 /* PL_curstack = PL_curstackinfo->si_stack; */
7683 PL_curstack = av_dup(proto_perl->Tcurstack);
7684 PL_mainstack = av_dup(proto_perl->Tmainstack);
7686 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7687 PL_stack_base = AvARRAY(PL_curstack);
7688 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7689 - proto_perl->Tstack_base);
7690 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7692 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7693 * NOTE: unlike the others! */
7694 PL_savestack_ix = proto_perl->Tsavestack_ix;
7695 PL_savestack_max = proto_perl->Tsavestack_max;
7696 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7697 PL_savestack = ss_dup(proto_perl);
7703 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7704 PL_top_env = &PL_start_env;
7706 PL_op = proto_perl->Top;
7709 PL_Xpv = (XPV*)NULL;
7710 PL_na = proto_perl->Tna;
7712 PL_statbuf = proto_perl->Tstatbuf;
7713 PL_statcache = proto_perl->Tstatcache;
7714 PL_statgv = gv_dup(proto_perl->Tstatgv);
7715 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7717 PL_timesbuf = proto_perl->Ttimesbuf;
7720 PL_tainted = proto_perl->Ttainted;
7721 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7722 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7723 PL_rs = sv_dup_inc(proto_perl->Trs);
7724 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7725 PL_ofslen = proto_perl->Tofslen;
7726 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7727 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7728 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7729 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7730 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7731 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7733 PL_restartop = proto_perl->Trestartop;
7734 PL_in_eval = proto_perl->Tin_eval;
7735 PL_delaymagic = proto_perl->Tdelaymagic;
7736 PL_dirty = proto_perl->Tdirty;
7737 PL_localizing = proto_perl->Tlocalizing;
7739 PL_protect = proto_perl->Tprotect;
7740 PL_errors = sv_dup_inc(proto_perl->Terrors);
7741 PL_av_fetch_sv = Nullsv;
7742 PL_hv_fetch_sv = Nullsv;
7743 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7744 PL_modcount = proto_perl->Tmodcount;
7745 PL_lastgotoprobe = Nullop;
7746 PL_dumpindent = proto_perl->Tdumpindent;
7748 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7749 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7750 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7751 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7752 PL_sortcxix = proto_perl->Tsortcxix;
7753 PL_efloatbuf = Nullch; /* reinits on demand */
7754 PL_efloatsize = 0; /* reinits on demand */
7758 PL_screamfirst = NULL;
7759 PL_screamnext = NULL;
7760 PL_maxscream = -1; /* reinits on demand */
7761 PL_lastscream = Nullsv;
7763 PL_watchaddr = NULL;
7764 PL_watchok = Nullch;
7766 PL_regdummy = proto_perl->Tregdummy;
7767 PL_regcomp_parse = Nullch;
7768 PL_regxend = Nullch;
7769 PL_regcode = (regnode*)NULL;
7772 PL_regprecomp = Nullch;
7777 PL_seen_zerolen = 0;
7779 PL_regcomp_rx = (regexp*)NULL;
7781 PL_colorset = 0; /* reinits PL_colors[] */
7782 /*PL_colors[6] = {0,0,0,0,0,0};*/
7783 PL_reg_whilem_seen = 0;
7784 PL_reginput = Nullch;
7787 PL_regstartp = (I32*)NULL;
7788 PL_regendp = (I32*)NULL;
7789 PL_reglastparen = (U32*)NULL;
7790 PL_regtill = Nullch;
7792 PL_reg_start_tmp = (char**)NULL;
7793 PL_reg_start_tmpl = 0;
7794 PL_regdata = (struct reg_data*)NULL;
7797 PL_reg_eval_set = 0;
7799 PL_regprogram = (regnode*)NULL;
7801 PL_regcc = (CURCUR*)NULL;
7802 PL_reg_call_cc = (struct re_cc_state*)NULL;
7803 PL_reg_re = (regexp*)NULL;
7804 PL_reg_ganch = Nullch;
7806 PL_reg_magic = (MAGIC*)NULL;
7808 PL_reg_oldcurpm = (PMOP*)NULL;
7809 PL_reg_curpm = (PMOP*)NULL;
7810 PL_reg_oldsaved = Nullch;
7811 PL_reg_oldsavedlen = 0;
7813 PL_reg_leftiter = 0;
7814 PL_reg_poscache = Nullch;
7815 PL_reg_poscache_size= 0;
7817 /* RE engine - function pointers */
7818 PL_regcompp = proto_perl->Tregcompp;
7819 PL_regexecp = proto_perl->Tregexecp;
7820 PL_regint_start = proto_perl->Tregint_start;
7821 PL_regint_string = proto_perl->Tregint_string;
7822 PL_regfree = proto_perl->Tregfree;
7824 PL_reginterp_cnt = 0;
7825 PL_reg_starttry = 0;
7828 return (PerlInterpreter*)pPerl;
7834 #else /* !USE_ITHREADS */
7840 #endif /* USE_ITHREADS */
7843 do_report_used(pTHXo_ SV *sv)
7845 if (SvTYPE(sv) != SVTYPEMASK) {
7846 PerlIO_printf(Perl_debug_log, "****\n");
7852 do_clean_objs(pTHXo_ SV *sv)
7856 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7857 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7863 /* XXX Might want to check arrays, etc. */
7866 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7868 do_clean_named_objs(pTHXo_ SV *sv)
7870 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
7871 if ( SvOBJECT(GvSV(sv)) ||
7872 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7873 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7874 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7875 GvCV(sv) && SvOBJECT(GvCV(sv)) )
7877 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
7885 do_clean_all(pTHXo_ SV *sv)
7887 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
7888 SvFLAGS(sv) |= SVf_BREAK;