3 * Copyright (c) 1991-2000, 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 > 255 || (uv > 127 && SvUTF8(sv))) && !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 argsv = va_arg(*args, SV*);
5881 else if (svix < svmax)
5882 argsv = svargs[svix++];
5885 U8 *str = (U8*)SvPVx(argsv,len);
5887 SV *vsv = NEWSV(73,vlen);
5889 U8 *vptr = (U8*)SvPVX(vsv);
5891 bool utf = DO_UTF8(argsv);
5899 uv = utf8_to_uv(str, &ulen);
5906 eptr = ebuf + sizeof ebuf;
5907 if (elen >= vlen-1) {
5908 STRLEN off = vptr - (U8*)SvPVX(vsv);
5911 vptr = SvPVX(vsv) + off;
5914 *--eptr = '0' + uv % 10;
5916 elen = (ebuf + sizeof ebuf) - eptr;
5917 memcpy(vptr, eptr, elen);
5926 SvCUR_set(vsv,vcur);
5934 * The "%_" hack might have to be changed someday,
5935 * if ISO or ANSI decide to use '_' for something.
5936 * So we keep it hidden from users' code.
5940 argsv = va_arg(*args,SV*);
5941 eptr = SvPVx(argsv, elen);
5946 if (has_precis && elen > precis)
5954 uv = PTR2UV(va_arg(*args, void*));
5956 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
5971 case 'h': iv = (short)va_arg(*args, int); break;
5972 default: iv = va_arg(*args, int); break;
5973 case 'l': iv = va_arg(*args, long); break;
5974 case 'V': iv = va_arg(*args, IV); break;
5976 case 'q': iv = va_arg(*args, Quad_t); break;
5981 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
5983 case 'h': iv = (short)iv; break;
5984 default: iv = (int)iv; break;
5985 case 'l': iv = (long)iv; break;
5988 case 'q': iv = (Quad_t)iv; break;
5995 esignbuf[esignlen++] = plus;
5999 esignbuf[esignlen++] = '-';
6037 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6038 default: uv = va_arg(*args, unsigned); break;
6039 case 'l': uv = va_arg(*args, unsigned long); break;
6040 case 'V': uv = va_arg(*args, UV); break;
6042 case 'q': uv = va_arg(*args, Quad_t); break;
6047 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6049 case 'h': uv = (unsigned short)uv; break;
6050 default: uv = (unsigned)uv; break;
6051 case 'l': uv = (unsigned long)uv; break;
6054 case 'q': uv = (Quad_t)uv; break;
6060 eptr = ebuf + sizeof ebuf;
6066 p = (char*)((c == 'X')
6067 ? "0123456789ABCDEF" : "0123456789abcdef");
6073 esignbuf[esignlen++] = '0';
6074 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6080 *--eptr = '0' + dig;
6082 if (alt && *eptr != '0')
6088 *--eptr = '0' + dig;
6091 esignbuf[esignlen++] = '0';
6092 esignbuf[esignlen++] = 'b';
6095 default: /* it had better be ten or less */
6096 #if defined(PERL_Y2KWARN)
6097 if (ckWARN(WARN_MISC)) {
6099 char *s = SvPV(sv,n);
6100 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6101 && (n == 2 || !isDIGIT(s[n-3])))
6103 Perl_warner(aTHX_ WARN_MISC,
6104 "Possible Y2K bug: %%%c %s",
6105 c, "format string following '19'");
6111 *--eptr = '0' + dig;
6112 } while (uv /= base);
6115 elen = (ebuf + sizeof ebuf) - eptr;
6118 zeros = precis - elen;
6119 else if (precis == 0 && elen == 1 && *eptr == '0')
6124 /* FLOATING POINT */
6127 c = 'f'; /* maybe %F isn't supported here */
6133 /* This is evil, but floating point is even more evil */
6136 nv = va_arg(*args, NV);
6138 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6141 if (c != 'e' && c != 'E') {
6143 (void)frexp(nv, &i);
6144 if (i == PERL_INT_MIN)
6145 Perl_die(aTHX_ "panic: frexp");
6147 need = BIT_DIGITS(i);
6149 need += has_precis ? precis : 6; /* known default */
6153 need += 20; /* fudge factor */
6154 if (PL_efloatsize < need) {
6155 Safefree(PL_efloatbuf);
6156 PL_efloatsize = need + 20; /* more fudge */
6157 New(906, PL_efloatbuf, PL_efloatsize, char);
6158 PL_efloatbuf[0] = '\0';
6161 eptr = ebuf + sizeof ebuf;
6164 #ifdef USE_LONG_DOUBLE
6166 char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3;
6167 while (p >= PERL_PRIfldbl) { *--eptr = *p--; }
6172 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6177 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6190 RESTORE_NUMERIC_STANDARD();
6191 (void)sprintf(PL_efloatbuf, eptr, nv);
6192 RESTORE_NUMERIC_LOCAL();
6195 eptr = PL_efloatbuf;
6196 elen = strlen(PL_efloatbuf);
6202 i = SvCUR(sv) - origlen;
6205 case 'h': *(va_arg(*args, short*)) = i; break;
6206 default: *(va_arg(*args, int*)) = i; break;
6207 case 'l': *(va_arg(*args, long*)) = i; break;
6208 case 'V': *(va_arg(*args, IV*)) = i; break;
6210 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6214 else if (svix < svmax)
6215 sv_setuv(svargs[svix++], (UV)i);
6216 continue; /* not "break" */
6222 if (!args && ckWARN(WARN_PRINTF) &&
6223 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6224 SV *msg = sv_newmortal();
6225 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6226 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6229 Perl_sv_catpvf(aTHX_ msg,
6230 "\"%%%c\"", c & 0xFF);
6232 Perl_sv_catpvf(aTHX_ msg,
6233 "\"%%\\%03"UVof"\"",
6236 sv_catpv(msg, "end of string");
6237 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6240 /* output mangled stuff ... */
6246 /* ... right here, because formatting flags should not apply */
6247 SvGROW(sv, SvCUR(sv) + elen + 1);
6249 memcpy(p, eptr, elen);
6252 SvCUR(sv) = p - SvPVX(sv);
6253 continue; /* not "break" */
6256 have = esignlen + zeros + elen;
6257 need = (have > width ? have : width);
6260 SvGROW(sv, SvCUR(sv) + need + 1);
6262 if (esignlen && fill == '0') {
6263 for (i = 0; i < esignlen; i++)
6267 memset(p, fill, gap);
6270 if (esignlen && fill != '0') {
6271 for (i = 0; i < esignlen; i++)
6275 for (i = zeros; i; i--)
6279 memcpy(p, eptr, elen);
6283 memset(p, ' ', gap);
6289 SvCUR(sv) = p - SvPVX(sv);
6293 #if defined(USE_ITHREADS)
6295 #if defined(USE_THREADS)
6296 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6299 #ifndef OpREFCNT_inc
6300 # define OpREFCNT_inc(o) ((o) ? (++(o)->op_targ, (o)) : Nullop)
6303 #ifndef GpREFCNT_inc
6304 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6308 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6309 #define av_dup(s) (AV*)sv_dup((SV*)s)
6310 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6311 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6312 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6313 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6314 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6315 #define io_dup(s) (IO*)sv_dup((SV*)s)
6316 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6317 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6318 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6319 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6320 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6323 Perl_re_dup(pTHX_ REGEXP *r)
6325 /* XXX fix when pmop->op_pmregexp becomes shared */
6326 return ReREFCNT_inc(r);
6330 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6334 return (PerlIO*)NULL;
6336 /* look for it in the table first */
6337 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6341 /* create anew and remember what it is */
6342 ret = PerlIO_fdupopen(fp);
6343 ptr_table_store(PL_ptr_table, fp, ret);
6348 Perl_dirp_dup(pTHX_ DIR *dp)
6357 Perl_gp_dup(pTHX_ GP *gp)
6362 /* look for it in the table first */
6363 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6367 /* create anew and remember what it is */
6368 Newz(0, ret, 1, GP);
6369 ptr_table_store(PL_ptr_table, gp, ret);
6372 ret->gp_refcnt = 0; /* must be before any other dups! */
6373 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6374 ret->gp_io = io_dup_inc(gp->gp_io);
6375 ret->gp_form = cv_dup_inc(gp->gp_form);
6376 ret->gp_av = av_dup_inc(gp->gp_av);
6377 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6378 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6379 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6380 ret->gp_cvgen = gp->gp_cvgen;
6381 ret->gp_flags = gp->gp_flags;
6382 ret->gp_line = gp->gp_line;
6383 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6388 Perl_mg_dup(pTHX_ MAGIC *mg)
6390 MAGIC *mgret = (MAGIC*)NULL;
6393 return (MAGIC*)NULL;
6394 /* look for it in the table first */
6395 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6399 for (; mg; mg = mg->mg_moremagic) {
6401 Newz(0, nmg, 1, MAGIC);
6405 mgprev->mg_moremagic = nmg;
6406 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6407 nmg->mg_private = mg->mg_private;
6408 nmg->mg_type = mg->mg_type;
6409 nmg->mg_flags = mg->mg_flags;
6410 if (mg->mg_type == 'r') {
6411 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6414 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6415 ? sv_dup_inc(mg->mg_obj)
6416 : sv_dup(mg->mg_obj);
6418 nmg->mg_len = mg->mg_len;
6419 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6420 if (mg->mg_ptr && mg->mg_type != 'g') {
6421 if (mg->mg_len >= 0) {
6422 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6423 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6424 AMT *amtp = (AMT*)mg->mg_ptr;
6425 AMT *namtp = (AMT*)nmg->mg_ptr;
6427 for (i = 1; i < NofAMmeth; i++) {
6428 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6432 else if (mg->mg_len == HEf_SVKEY)
6433 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6441 Perl_ptr_table_new(pTHX)
6444 Newz(0, tbl, 1, PTR_TBL_t);
6447 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6452 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6454 PTR_TBL_ENT_t *tblent;
6455 UV hash = PTR2UV(sv);
6457 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6458 for (; tblent; tblent = tblent->next) {
6459 if (tblent->oldval == sv)
6460 return tblent->newval;
6466 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6468 PTR_TBL_ENT_t *tblent, **otblent;
6469 /* XXX this may be pessimal on platforms where pointers aren't good
6470 * hash values e.g. if they grow faster in the most significant
6472 UV hash = PTR2UV(oldv);
6476 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6477 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6478 if (tblent->oldval == oldv) {
6479 tblent->newval = newv;
6484 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6485 tblent->oldval = oldv;
6486 tblent->newval = newv;
6487 tblent->next = *otblent;
6490 if (i && tbl->tbl_items > tbl->tbl_max)
6491 ptr_table_split(tbl);
6495 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6497 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6498 UV oldsize = tbl->tbl_max + 1;
6499 UV newsize = oldsize * 2;
6502 Renew(ary, newsize, PTR_TBL_ENT_t*);
6503 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6504 tbl->tbl_max = --newsize;
6506 for (i=0; i < oldsize; i++, ary++) {
6507 PTR_TBL_ENT_t **curentp, **entp, *ent;
6510 curentp = ary + oldsize;
6511 for (entp = ary, ent = *ary; ent; ent = *entp) {
6512 if ((newsize & PTR2UV(ent->oldval)) != i) {
6514 ent->next = *curentp;
6529 Perl_sv_dup(pTHX_ SV *sstr)
6536 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6538 /* look for it in the table first */
6539 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6543 /* create anew and remember what it is */
6545 ptr_table_store(PL_ptr_table, sstr, dstr);
6548 SvFLAGS(dstr) = SvFLAGS(sstr);
6549 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6550 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6553 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6554 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6555 PL_watch_pvx, SvPVX(sstr));
6558 switch (SvTYPE(sstr)) {
6563 SvANY(dstr) = new_XIV();
6564 SvIVX(dstr) = SvIVX(sstr);
6567 SvANY(dstr) = new_XNV();
6568 SvNVX(dstr) = SvNVX(sstr);
6571 SvANY(dstr) = new_XRV();
6572 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6575 SvANY(dstr) = new_XPV();
6576 SvCUR(dstr) = SvCUR(sstr);
6577 SvLEN(dstr) = SvLEN(sstr);
6579 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6580 else if (SvPVX(sstr) && SvLEN(sstr))
6581 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6583 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6586 SvANY(dstr) = new_XPVIV();
6587 SvCUR(dstr) = SvCUR(sstr);
6588 SvLEN(dstr) = SvLEN(sstr);
6589 SvIVX(dstr) = SvIVX(sstr);
6591 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6592 else if (SvPVX(sstr) && SvLEN(sstr))
6593 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6595 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6598 SvANY(dstr) = new_XPVNV();
6599 SvCUR(dstr) = SvCUR(sstr);
6600 SvLEN(dstr) = SvLEN(sstr);
6601 SvIVX(dstr) = SvIVX(sstr);
6602 SvNVX(dstr) = SvNVX(sstr);
6604 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6605 else if (SvPVX(sstr) && SvLEN(sstr))
6606 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6608 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6611 SvANY(dstr) = new_XPVMG();
6612 SvCUR(dstr) = SvCUR(sstr);
6613 SvLEN(dstr) = SvLEN(sstr);
6614 SvIVX(dstr) = SvIVX(sstr);
6615 SvNVX(dstr) = SvNVX(sstr);
6616 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6617 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6619 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6620 else if (SvPVX(sstr) && SvLEN(sstr))
6621 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6623 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6626 SvANY(dstr) = new_XPVBM();
6627 SvCUR(dstr) = SvCUR(sstr);
6628 SvLEN(dstr) = SvLEN(sstr);
6629 SvIVX(dstr) = SvIVX(sstr);
6630 SvNVX(dstr) = SvNVX(sstr);
6631 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6632 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6634 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6635 else if (SvPVX(sstr) && SvLEN(sstr))
6636 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6638 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6639 BmRARE(dstr) = BmRARE(sstr);
6640 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6641 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6644 SvANY(dstr) = new_XPVLV();
6645 SvCUR(dstr) = SvCUR(sstr);
6646 SvLEN(dstr) = SvLEN(sstr);
6647 SvIVX(dstr) = SvIVX(sstr);
6648 SvNVX(dstr) = SvNVX(sstr);
6649 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6650 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6652 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6653 else if (SvPVX(sstr) && SvLEN(sstr))
6654 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6656 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6657 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6658 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6659 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6660 LvTYPE(dstr) = LvTYPE(sstr);
6663 SvANY(dstr) = new_XPVGV();
6664 SvCUR(dstr) = SvCUR(sstr);
6665 SvLEN(dstr) = SvLEN(sstr);
6666 SvIVX(dstr) = SvIVX(sstr);
6667 SvNVX(dstr) = SvNVX(sstr);
6668 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6669 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6671 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6672 else if (SvPVX(sstr) && SvLEN(sstr))
6673 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6675 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6676 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6677 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6678 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6679 GvFLAGS(dstr) = GvFLAGS(sstr);
6680 GvGP(dstr) = gp_dup(GvGP(sstr));
6681 (void)GpREFCNT_inc(GvGP(dstr));
6684 SvANY(dstr) = new_XPVIO();
6685 SvCUR(dstr) = SvCUR(sstr);
6686 SvLEN(dstr) = SvLEN(sstr);
6687 SvIVX(dstr) = SvIVX(sstr);
6688 SvNVX(dstr) = SvNVX(sstr);
6689 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6690 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6692 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6693 else if (SvPVX(sstr) && SvLEN(sstr))
6694 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6696 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6697 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6698 if (IoOFP(sstr) == IoIFP(sstr))
6699 IoOFP(dstr) = IoIFP(dstr);
6701 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6702 /* PL_rsfp_filters entries have fake IoDIRP() */
6703 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6704 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6706 IoDIRP(dstr) = IoDIRP(sstr);
6707 IoLINES(dstr) = IoLINES(sstr);
6708 IoPAGE(dstr) = IoPAGE(sstr);
6709 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6710 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6711 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6712 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6713 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6714 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6715 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6716 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6717 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6718 IoTYPE(dstr) = IoTYPE(sstr);
6719 IoFLAGS(dstr) = IoFLAGS(sstr);
6722 SvANY(dstr) = new_XPVAV();
6723 SvCUR(dstr) = SvCUR(sstr);
6724 SvLEN(dstr) = SvLEN(sstr);
6725 SvIVX(dstr) = SvIVX(sstr);
6726 SvNVX(dstr) = SvNVX(sstr);
6727 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6728 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6729 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6730 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6731 if (AvARRAY((AV*)sstr)) {
6732 SV **dst_ary, **src_ary;
6733 SSize_t items = AvFILLp((AV*)sstr) + 1;
6735 src_ary = AvARRAY((AV*)sstr);
6736 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6737 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6738 SvPVX(dstr) = (char*)dst_ary;
6739 AvALLOC((AV*)dstr) = dst_ary;
6740 if (AvREAL((AV*)sstr)) {
6742 *dst_ary++ = sv_dup_inc(*src_ary++);
6746 *dst_ary++ = sv_dup(*src_ary++);
6748 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6749 while (items-- > 0) {
6750 *dst_ary++ = &PL_sv_undef;
6754 SvPVX(dstr) = Nullch;
6755 AvALLOC((AV*)dstr) = (SV**)NULL;
6759 SvANY(dstr) = new_XPVHV();
6760 SvCUR(dstr) = SvCUR(sstr);
6761 SvLEN(dstr) = SvLEN(sstr);
6762 SvIVX(dstr) = SvIVX(sstr);
6763 SvNVX(dstr) = SvNVX(sstr);
6764 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6765 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6766 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6767 if (HvARRAY((HV*)sstr)) {
6770 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6771 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6772 Newz(0, dxhv->xhv_array,
6773 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6774 while (i <= sxhv->xhv_max) {
6775 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6776 !!HvSHAREKEYS(sstr));
6779 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
6782 SvPVX(dstr) = Nullch;
6783 HvEITER((HV*)dstr) = (HE*)NULL;
6785 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
6786 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
6789 SvANY(dstr) = new_XPVFM();
6790 FmLINES(dstr) = FmLINES(sstr);
6794 SvANY(dstr) = new_XPVCV();
6796 SvCUR(dstr) = SvCUR(sstr);
6797 SvLEN(dstr) = SvLEN(sstr);
6798 SvIVX(dstr) = SvIVX(sstr);
6799 SvNVX(dstr) = SvNVX(sstr);
6800 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6801 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6802 if (SvPVX(sstr) && SvLEN(sstr))
6803 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6805 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6806 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
6807 CvSTART(dstr) = CvSTART(sstr);
6808 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
6809 CvXSUB(dstr) = CvXSUB(sstr);
6810 CvXSUBANY(dstr) = CvXSUBANY(sstr);
6811 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
6812 CvDEPTH(dstr) = CvDEPTH(sstr);
6813 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
6814 /* XXX padlists are real, but pretend to be not */
6815 AvREAL_on(CvPADLIST(sstr));
6816 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6817 AvREAL_off(CvPADLIST(sstr));
6818 AvREAL_off(CvPADLIST(dstr));
6821 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
6822 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
6823 CvFLAGS(dstr) = CvFLAGS(sstr);
6826 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
6830 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
6837 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
6842 return (PERL_CONTEXT*)NULL;
6844 /* look for it in the table first */
6845 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
6849 /* create anew and remember what it is */
6850 Newz(56, ncxs, max + 1, PERL_CONTEXT);
6851 ptr_table_store(PL_ptr_table, cxs, ncxs);
6854 PERL_CONTEXT *cx = &cxs[ix];
6855 PERL_CONTEXT *ncx = &ncxs[ix];
6856 ncx->cx_type = cx->cx_type;
6857 if (CxTYPE(cx) == CXt_SUBST) {
6858 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
6861 ncx->blk_oldsp = cx->blk_oldsp;
6862 ncx->blk_oldcop = cx->blk_oldcop;
6863 ncx->blk_oldretsp = cx->blk_oldretsp;
6864 ncx->blk_oldmarksp = cx->blk_oldmarksp;
6865 ncx->blk_oldscopesp = cx->blk_oldscopesp;
6866 ncx->blk_oldpm = cx->blk_oldpm;
6867 ncx->blk_gimme = cx->blk_gimme;
6868 switch (CxTYPE(cx)) {
6870 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
6871 ? cv_dup_inc(cx->blk_sub.cv)
6872 : cv_dup(cx->blk_sub.cv));
6873 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
6874 ? av_dup_inc(cx->blk_sub.argarray)
6876 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
6877 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
6878 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6879 ncx->blk_sub.lval = cx->blk_sub.lval;
6882 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
6883 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
6884 ncx->blk_eval.old_name = SAVEPV(cx->blk_eval.old_name);
6885 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
6886 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
6889 ncx->blk_loop.label = cx->blk_loop.label;
6890 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
6891 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
6892 ncx->blk_loop.next_op = cx->blk_loop.next_op;
6893 ncx->blk_loop.last_op = cx->blk_loop.last_op;
6894 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
6895 ? cx->blk_loop.iterdata
6896 : gv_dup((GV*)cx->blk_loop.iterdata));
6897 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
6898 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
6899 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
6900 ncx->blk_loop.iterix = cx->blk_loop.iterix;
6901 ncx->blk_loop.itermax = cx->blk_loop.itermax;
6904 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
6905 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
6906 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
6907 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
6920 Perl_si_dup(pTHX_ PERL_SI *si)
6925 return (PERL_SI*)NULL;
6927 /* look for it in the table first */
6928 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
6932 /* create anew and remember what it is */
6933 Newz(56, nsi, 1, PERL_SI);
6934 ptr_table_store(PL_ptr_table, si, nsi);
6936 nsi->si_stack = av_dup_inc(si->si_stack);
6937 nsi->si_cxix = si->si_cxix;
6938 nsi->si_cxmax = si->si_cxmax;
6939 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
6940 nsi->si_type = si->si_type;
6941 nsi->si_prev = si_dup(si->si_prev);
6942 nsi->si_next = si_dup(si->si_next);
6943 nsi->si_markoff = si->si_markoff;
6948 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
6949 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
6950 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
6951 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
6952 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
6953 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
6954 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
6955 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
6956 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
6957 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
6958 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
6959 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
6962 #define pv_dup_inc(p) SAVEPV(p)
6963 #define pv_dup(p) SAVEPV(p)
6964 #define svp_dup_inc(p,pp) any_dup(p,pp)
6967 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
6974 /* look for it in the table first */
6975 ret = ptr_table_fetch(PL_ptr_table, v);
6979 /* see if it is part of the interpreter structure */
6980 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
6981 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
6989 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
6991 ANY *ss = proto_perl->Tsavestack;
6992 I32 ix = proto_perl->Tsavestack_ix;
6993 I32 max = proto_perl->Tsavestack_max;
7006 void (*dptr) (void*);
7007 void (*dxptr) (pTHXo_ void*);
7009 Newz(54, nss, max, ANY);
7015 case SAVEt_ITEM: /* normal string */
7016 sv = (SV*)POPPTR(ss,ix);
7017 TOPPTR(nss,ix) = sv_dup_inc(sv);
7018 sv = (SV*)POPPTR(ss,ix);
7019 TOPPTR(nss,ix) = sv_dup_inc(sv);
7021 case SAVEt_SV: /* scalar reference */
7022 sv = (SV*)POPPTR(ss,ix);
7023 TOPPTR(nss,ix) = sv_dup_inc(sv);
7024 gv = (GV*)POPPTR(ss,ix);
7025 TOPPTR(nss,ix) = gv_dup_inc(gv);
7027 case SAVEt_GENERIC_SVREF: /* generic sv */
7028 case SAVEt_SVREF: /* scalar reference */
7029 sv = (SV*)POPPTR(ss,ix);
7030 TOPPTR(nss,ix) = sv_dup_inc(sv);
7031 ptr = POPPTR(ss,ix);
7032 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7034 case SAVEt_AV: /* array reference */
7035 av = (AV*)POPPTR(ss,ix);
7036 TOPPTR(nss,ix) = av_dup_inc(av);
7037 gv = (GV*)POPPTR(ss,ix);
7038 TOPPTR(nss,ix) = gv_dup(gv);
7040 case SAVEt_HV: /* hash reference */
7041 hv = (HV*)POPPTR(ss,ix);
7042 TOPPTR(nss,ix) = hv_dup_inc(hv);
7043 gv = (GV*)POPPTR(ss,ix);
7044 TOPPTR(nss,ix) = gv_dup(gv);
7046 case SAVEt_INT: /* int reference */
7047 ptr = POPPTR(ss,ix);
7048 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7049 intval = (int)POPINT(ss,ix);
7050 TOPINT(nss,ix) = intval;
7052 case SAVEt_LONG: /* long reference */
7053 ptr = POPPTR(ss,ix);
7054 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7055 longval = (long)POPLONG(ss,ix);
7056 TOPLONG(nss,ix) = longval;
7058 case SAVEt_I32: /* I32 reference */
7059 case SAVEt_I16: /* I16 reference */
7060 case SAVEt_I8: /* I8 reference */
7061 ptr = POPPTR(ss,ix);
7062 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7066 case SAVEt_IV: /* IV reference */
7067 ptr = POPPTR(ss,ix);
7068 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7072 case SAVEt_SPTR: /* SV* reference */
7073 ptr = POPPTR(ss,ix);
7074 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7075 sv = (SV*)POPPTR(ss,ix);
7076 TOPPTR(nss,ix) = sv_dup(sv);
7078 case SAVEt_VPTR: /* random* reference */
7079 ptr = POPPTR(ss,ix);
7080 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7081 ptr = POPPTR(ss,ix);
7082 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7084 case SAVEt_PPTR: /* char* reference */
7085 ptr = POPPTR(ss,ix);
7086 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7087 c = (char*)POPPTR(ss,ix);
7088 TOPPTR(nss,ix) = pv_dup(c);
7090 case SAVEt_HPTR: /* HV* reference */
7091 ptr = POPPTR(ss,ix);
7092 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7093 hv = (HV*)POPPTR(ss,ix);
7094 TOPPTR(nss,ix) = hv_dup(hv);
7096 case SAVEt_APTR: /* AV* reference */
7097 ptr = POPPTR(ss,ix);
7098 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7099 av = (AV*)POPPTR(ss,ix);
7100 TOPPTR(nss,ix) = av_dup(av);
7103 gv = (GV*)POPPTR(ss,ix);
7104 TOPPTR(nss,ix) = gv_dup(gv);
7106 case SAVEt_GP: /* scalar reference */
7107 gp = (GP*)POPPTR(ss,ix);
7108 TOPPTR(nss,ix) = gp = gp_dup(gp);
7109 (void)GpREFCNT_inc(gp);
7110 gv = (GV*)POPPTR(ss,ix);
7111 TOPPTR(nss,ix) = gv_dup_inc(c);
7112 c = (char*)POPPTR(ss,ix);
7113 TOPPTR(nss,ix) = pv_dup(c);
7120 sv = (SV*)POPPTR(ss,ix);
7121 TOPPTR(nss,ix) = sv_dup_inc(sv);
7124 ptr = POPPTR(ss,ix);
7125 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7126 /* these are assumed to be refcounted properly */
7127 switch (((OP*)ptr)->op_type) {
7134 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7137 TOPPTR(nss,ix) = Nullop;
7142 TOPPTR(nss,ix) = Nullop;
7145 c = (char*)POPPTR(ss,ix);
7146 TOPPTR(nss,ix) = pv_dup_inc(c);
7149 longval = POPLONG(ss,ix);
7150 TOPLONG(nss,ix) = longval;
7153 hv = (HV*)POPPTR(ss,ix);
7154 TOPPTR(nss,ix) = hv_dup_inc(hv);
7155 c = (char*)POPPTR(ss,ix);
7156 TOPPTR(nss,ix) = pv_dup_inc(c);
7160 case SAVEt_DESTRUCTOR:
7161 ptr = POPPTR(ss,ix);
7162 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7163 dptr = POPDPTR(ss,ix);
7164 TOPDPTR(nss,ix) = (void (*)(void*))any_dup(dptr, proto_perl);
7166 case SAVEt_DESTRUCTOR_X:
7167 ptr = POPPTR(ss,ix);
7168 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7169 dxptr = POPDXPTR(ss,ix);
7170 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup(dxptr, proto_perl);
7172 case SAVEt_REGCONTEXT:
7178 case SAVEt_STACK_POS: /* Position on Perl stack */
7182 case SAVEt_AELEM: /* array element */
7183 sv = (SV*)POPPTR(ss,ix);
7184 TOPPTR(nss,ix) = sv_dup_inc(sv);
7187 av = (AV*)POPPTR(ss,ix);
7188 TOPPTR(nss,ix) = av_dup_inc(av);
7190 case SAVEt_HELEM: /* hash element */
7191 sv = (SV*)POPPTR(ss,ix);
7192 TOPPTR(nss,ix) = sv_dup_inc(sv);
7193 sv = (SV*)POPPTR(ss,ix);
7194 TOPPTR(nss,ix) = sv_dup_inc(sv);
7195 hv = (HV*)POPPTR(ss,ix);
7196 TOPPTR(nss,ix) = hv_dup_inc(hv);
7199 ptr = POPPTR(ss,ix);
7200 TOPPTR(nss,ix) = ptr;
7207 av = (AV*)POPPTR(ss,ix);
7208 TOPPTR(nss,ix) = av_dup(av);
7211 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7223 perl_clone(PerlInterpreter *proto_perl, UV flags)
7226 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7229 #ifdef PERL_IMPLICIT_SYS
7230 return perl_clone_using(proto_perl, flags,
7232 proto_perl->IMemShared,
7233 proto_perl->IMemParse,
7243 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7244 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7245 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7246 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7247 struct IPerlDir* ipD, struct IPerlSock* ipS,
7248 struct IPerlProc* ipP)
7250 /* XXX many of the string copies here can be optimized if they're
7251 * constants; they need to be allocated as common memory and just
7252 * their pointers copied. */
7258 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7260 PERL_SET_INTERP(pPerl);
7261 # else /* !PERL_OBJECT */
7262 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7263 PERL_SET_INTERP(my_perl);
7266 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7271 # else /* !DEBUGGING */
7272 Zero(my_perl, 1, PerlInterpreter);
7273 # endif /* DEBUGGING */
7277 PL_MemShared = ipMS;
7285 # endif /* PERL_OBJECT */
7286 #else /* !PERL_IMPLICIT_SYS */
7290 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7291 PERL_SET_INTERP(my_perl);
7294 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7299 # else /* !DEBUGGING */
7300 Zero(my_perl, 1, PerlInterpreter);
7301 # endif /* DEBUGGING */
7302 #endif /* PERL_IMPLICIT_SYS */
7305 PL_xiv_arenaroot = NULL;
7310 PL_xpviv_root = NULL;
7311 PL_xpvnv_root = NULL;
7312 PL_xpvcv_root = NULL;
7313 PL_xpvav_root = NULL;
7314 PL_xpvhv_root = NULL;
7315 PL_xpvmg_root = NULL;
7316 PL_xpvlv_root = NULL;
7317 PL_xpvbm_root = NULL;
7319 PL_nice_chunk = NULL;
7320 PL_nice_chunk_size = 0;
7323 PL_sv_root = Nullsv;
7324 PL_sv_arenaroot = Nullsv;
7326 PL_debug = proto_perl->Idebug;
7328 /* create SV map for pointer relocation */
7329 PL_ptr_table = ptr_table_new();
7331 /* initialize these special pointers as early as possible */
7332 SvANY(&PL_sv_undef) = NULL;
7333 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7334 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7335 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7338 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7340 SvANY(&PL_sv_no) = new_XPVNV();
7342 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7343 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7344 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7345 SvCUR(&PL_sv_no) = 0;
7346 SvLEN(&PL_sv_no) = 1;
7347 SvNVX(&PL_sv_no) = 0;
7348 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7351 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7353 SvANY(&PL_sv_yes) = new_XPVNV();
7355 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7356 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7357 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7358 SvCUR(&PL_sv_yes) = 1;
7359 SvLEN(&PL_sv_yes) = 2;
7360 SvNVX(&PL_sv_yes) = 1;
7361 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7363 /* create shared string table */
7364 PL_strtab = newHV();
7365 HvSHAREKEYS_off(PL_strtab);
7366 hv_ksplit(PL_strtab, 512);
7367 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7369 PL_compiling = proto_perl->Icompiling;
7370 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7371 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7372 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7373 if (!specialWARN(PL_compiling.cop_warnings))
7374 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7375 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7377 /* pseudo environmental stuff */
7378 PL_origargc = proto_perl->Iorigargc;
7380 New(0, PL_origargv, i+1, char*);
7381 PL_origargv[i] = '\0';
7383 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7385 PL_envgv = gv_dup(proto_perl->Ienvgv);
7386 PL_incgv = gv_dup(proto_perl->Iincgv);
7387 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7388 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7389 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7390 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7393 PL_minus_c = proto_perl->Iminus_c;
7394 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7395 PL_localpatches = proto_perl->Ilocalpatches;
7396 PL_splitstr = proto_perl->Isplitstr;
7397 PL_preprocess = proto_perl->Ipreprocess;
7398 PL_minus_n = proto_perl->Iminus_n;
7399 PL_minus_p = proto_perl->Iminus_p;
7400 PL_minus_l = proto_perl->Iminus_l;
7401 PL_minus_a = proto_perl->Iminus_a;
7402 PL_minus_F = proto_perl->Iminus_F;
7403 PL_doswitches = proto_perl->Idoswitches;
7404 PL_dowarn = proto_perl->Idowarn;
7405 PL_doextract = proto_perl->Idoextract;
7406 PL_sawampersand = proto_perl->Isawampersand;
7407 PL_unsafe = proto_perl->Iunsafe;
7408 PL_inplace = SAVEPV(proto_perl->Iinplace);
7409 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7410 PL_perldb = proto_perl->Iperldb;
7411 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7413 /* magical thingies */
7414 /* XXX time(&PL_basetime) when asked for? */
7415 PL_basetime = proto_perl->Ibasetime;
7416 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7418 PL_maxsysfd = proto_perl->Imaxsysfd;
7419 PL_multiline = proto_perl->Imultiline;
7420 PL_statusvalue = proto_perl->Istatusvalue;
7422 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7425 /* shortcuts to various I/O objects */
7426 PL_stdingv = gv_dup(proto_perl->Istdingv);
7427 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7428 PL_defgv = gv_dup(proto_perl->Idefgv);
7429 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7430 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7431 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7433 /* shortcuts to regexp stuff */
7434 PL_replgv = gv_dup(proto_perl->Ireplgv);
7436 /* shortcuts to misc objects */
7437 PL_errgv = gv_dup(proto_perl->Ierrgv);
7439 /* shortcuts to debugging objects */
7440 PL_DBgv = gv_dup(proto_perl->IDBgv);
7441 PL_DBline = gv_dup(proto_perl->IDBline);
7442 PL_DBsub = gv_dup(proto_perl->IDBsub);
7443 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7444 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7445 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7446 PL_lineary = av_dup(proto_perl->Ilineary);
7447 PL_dbargs = av_dup(proto_perl->Idbargs);
7450 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7451 PL_curstash = hv_dup(proto_perl->Tcurstash);
7452 PL_debstash = hv_dup(proto_perl->Idebstash);
7453 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7454 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7456 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7457 PL_endav = av_dup_inc(proto_perl->Iendav);
7458 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7459 PL_initav = av_dup_inc(proto_perl->Iinitav);
7461 PL_sub_generation = proto_perl->Isub_generation;
7463 /* funky return mechanisms */
7464 PL_forkprocess = proto_perl->Iforkprocess;
7466 /* subprocess state */
7467 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7469 /* internal state */
7470 PL_tainting = proto_perl->Itainting;
7471 PL_maxo = proto_perl->Imaxo;
7472 if (proto_perl->Iop_mask)
7473 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7475 PL_op_mask = Nullch;
7477 /* current interpreter roots */
7478 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7479 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7480 PL_main_start = proto_perl->Imain_start;
7481 PL_eval_root = OpREFCNT_inc(proto_perl->Ieval_root);
7482 PL_eval_start = proto_perl->Ieval_start;
7484 /* runtime control stuff */
7485 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7486 PL_copline = proto_perl->Icopline;
7488 PL_filemode = proto_perl->Ifilemode;
7489 PL_lastfd = proto_perl->Ilastfd;
7490 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7493 PL_gensym = proto_perl->Igensym;
7494 PL_preambled = proto_perl->Ipreambled;
7495 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7496 PL_laststatval = proto_perl->Ilaststatval;
7497 PL_laststype = proto_perl->Ilaststype;
7498 PL_mess_sv = Nullsv;
7500 PL_orslen = proto_perl->Iorslen;
7501 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7502 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7504 /* interpreter atexit processing */
7505 PL_exitlistlen = proto_perl->Iexitlistlen;
7506 if (PL_exitlistlen) {
7507 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7508 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7511 PL_exitlist = (PerlExitListEntry*)NULL;
7512 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7514 PL_profiledata = NULL;
7515 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7516 /* PL_rsfp_filters entries have fake IoDIRP() */
7517 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7519 PL_compcv = cv_dup(proto_perl->Icompcv);
7520 PL_comppad = av_dup(proto_perl->Icomppad);
7521 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7522 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7523 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7524 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7525 proto_perl->Tcurpad);
7527 #ifdef HAVE_INTERP_INTERN
7528 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7531 /* more statics moved here */
7532 PL_generation = proto_perl->Igeneration;
7533 PL_DBcv = cv_dup(proto_perl->IDBcv);
7535 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7536 PL_in_clean_all = proto_perl->Iin_clean_all;
7538 PL_uid = proto_perl->Iuid;
7539 PL_euid = proto_perl->Ieuid;
7540 PL_gid = proto_perl->Igid;
7541 PL_egid = proto_perl->Iegid;
7542 PL_nomemok = proto_perl->Inomemok;
7543 PL_an = proto_perl->Ian;
7544 PL_cop_seqmax = proto_perl->Icop_seqmax;
7545 PL_op_seqmax = proto_perl->Iop_seqmax;
7546 PL_evalseq = proto_perl->Ievalseq;
7547 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7548 PL_origalen = proto_perl->Iorigalen;
7549 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7550 PL_osname = SAVEPV(proto_perl->Iosname);
7551 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7552 PL_sighandlerp = proto_perl->Isighandlerp;
7555 PL_runops = proto_perl->Irunops;
7557 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7560 PL_cshlen = proto_perl->Icshlen;
7561 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7564 PL_lex_state = proto_perl->Ilex_state;
7565 PL_lex_defer = proto_perl->Ilex_defer;
7566 PL_lex_expect = proto_perl->Ilex_expect;
7567 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7568 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7569 PL_lex_starts = proto_perl->Ilex_starts;
7570 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7571 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7572 PL_lex_op = proto_perl->Ilex_op;
7573 PL_lex_inpat = proto_perl->Ilex_inpat;
7574 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7575 PL_lex_brackets = proto_perl->Ilex_brackets;
7576 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7577 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7578 PL_lex_casemods = proto_perl->Ilex_casemods;
7579 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7580 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7582 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7583 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7584 PL_nexttoke = proto_perl->Inexttoke;
7586 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7587 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7588 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7589 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7590 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7591 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7592 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7593 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7594 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7595 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7596 PL_pending_ident = proto_perl->Ipending_ident;
7597 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7599 PL_expect = proto_perl->Iexpect;
7601 PL_multi_start = proto_perl->Imulti_start;
7602 PL_multi_end = proto_perl->Imulti_end;
7603 PL_multi_open = proto_perl->Imulti_open;
7604 PL_multi_close = proto_perl->Imulti_close;
7606 PL_error_count = proto_perl->Ierror_count;
7607 PL_subline = proto_perl->Isubline;
7608 PL_subname = sv_dup_inc(proto_perl->Isubname);
7610 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7611 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7612 PL_padix = proto_perl->Ipadix;
7613 PL_padix_floor = proto_perl->Ipadix_floor;
7614 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7616 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7617 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7618 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7619 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7620 PL_last_lop_op = proto_perl->Ilast_lop_op;
7621 PL_in_my = proto_perl->Iin_my;
7622 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7624 PL_cryptseen = proto_perl->Icryptseen;
7627 PL_hints = proto_perl->Ihints;
7629 PL_amagic_generation = proto_perl->Iamagic_generation;
7631 #ifdef USE_LOCALE_COLLATE
7632 PL_collation_ix = proto_perl->Icollation_ix;
7633 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7634 PL_collation_standard = proto_perl->Icollation_standard;
7635 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7636 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7637 #endif /* USE_LOCALE_COLLATE */
7639 #ifdef USE_LOCALE_NUMERIC
7640 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7641 PL_numeric_standard = proto_perl->Inumeric_standard;
7642 PL_numeric_local = proto_perl->Inumeric_local;
7643 PL_numeric_radix = proto_perl->Inumeric_radix;
7644 #endif /* !USE_LOCALE_NUMERIC */
7646 /* utf8 character classes */
7647 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7648 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7649 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7650 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7651 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7652 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7653 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7654 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7655 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7656 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7657 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7658 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7659 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7660 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7661 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7662 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7663 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7666 PL_last_swash_hv = Nullhv; /* reinits on demand */
7667 PL_last_swash_klen = 0;
7668 PL_last_swash_key[0]= '\0';
7669 PL_last_swash_tmps = (U8*)NULL;
7670 PL_last_swash_slen = 0;
7672 /* perly.c globals */
7673 PL_yydebug = proto_perl->Iyydebug;
7674 PL_yynerrs = proto_perl->Iyynerrs;
7675 PL_yyerrflag = proto_perl->Iyyerrflag;
7676 PL_yychar = proto_perl->Iyychar;
7677 PL_yyval = proto_perl->Iyyval;
7678 PL_yylval = proto_perl->Iyylval;
7680 PL_glob_index = proto_perl->Iglob_index;
7681 PL_srand_called = proto_perl->Isrand_called;
7682 PL_uudmap['M'] = 0; /* reinits on demand */
7683 PL_bitcount = Nullch; /* reinits on demand */
7685 if (proto_perl->Ipsig_ptr) {
7686 int sig_num[] = { SIG_NUM };
7687 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7688 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7689 for (i = 1; PL_sig_name[i]; i++) {
7690 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7691 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7695 PL_psig_ptr = (SV**)NULL;
7696 PL_psig_name = (SV**)NULL;
7699 /* thrdvar.h stuff */
7702 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7703 PL_tmps_ix = proto_perl->Ttmps_ix;
7704 PL_tmps_max = proto_perl->Ttmps_max;
7705 PL_tmps_floor = proto_perl->Ttmps_floor;
7706 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7708 while (i <= PL_tmps_ix) {
7709 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7713 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7714 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7715 Newz(54, PL_markstack, i, I32);
7716 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7717 - proto_perl->Tmarkstack);
7718 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7719 - proto_perl->Tmarkstack);
7720 Copy(proto_perl->Tmarkstack, PL_markstack,
7721 PL_markstack_ptr - PL_markstack + 1, I32);
7723 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7724 * NOTE: unlike the others! */
7725 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7726 PL_scopestack_max = proto_perl->Tscopestack_max;
7727 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7728 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7730 /* next push_return() sets PL_retstack[PL_retstack_ix]
7731 * NOTE: unlike the others! */
7732 PL_retstack_ix = proto_perl->Tretstack_ix;
7733 PL_retstack_max = proto_perl->Tretstack_max;
7734 Newz(54, PL_retstack, PL_retstack_max, OP*);
7735 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7737 /* NOTE: si_dup() looks at PL_markstack */
7738 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7740 /* PL_curstack = PL_curstackinfo->si_stack; */
7741 PL_curstack = av_dup(proto_perl->Tcurstack);
7742 PL_mainstack = av_dup(proto_perl->Tmainstack);
7744 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7745 PL_stack_base = AvARRAY(PL_curstack);
7746 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7747 - proto_perl->Tstack_base);
7748 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7750 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7751 * NOTE: unlike the others! */
7752 PL_savestack_ix = proto_perl->Tsavestack_ix;
7753 PL_savestack_max = proto_perl->Tsavestack_max;
7754 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7755 PL_savestack = ss_dup(proto_perl);
7761 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
7762 PL_top_env = &PL_start_env;
7764 PL_op = proto_perl->Top;
7767 PL_Xpv = (XPV*)NULL;
7768 PL_na = proto_perl->Tna;
7770 PL_statbuf = proto_perl->Tstatbuf;
7771 PL_statcache = proto_perl->Tstatcache;
7772 PL_statgv = gv_dup(proto_perl->Tstatgv);
7773 PL_statname = sv_dup_inc(proto_perl->Tstatname);
7775 PL_timesbuf = proto_perl->Ttimesbuf;
7778 PL_tainted = proto_perl->Ttainted;
7779 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
7780 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
7781 PL_rs = sv_dup_inc(proto_perl->Trs);
7782 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
7783 PL_ofslen = proto_perl->Tofslen;
7784 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
7785 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
7786 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
7787 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
7788 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
7789 PL_formtarget = sv_dup(proto_perl->Tformtarget);
7791 PL_restartop = proto_perl->Trestartop;
7792 PL_in_eval = proto_perl->Tin_eval;
7793 PL_delaymagic = proto_perl->Tdelaymagic;
7794 PL_dirty = proto_perl->Tdirty;
7795 PL_localizing = proto_perl->Tlocalizing;
7797 PL_protect = proto_perl->Tprotect;
7798 PL_errors = sv_dup_inc(proto_perl->Terrors);
7799 PL_av_fetch_sv = Nullsv;
7800 PL_hv_fetch_sv = Nullsv;
7801 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
7802 PL_modcount = proto_perl->Tmodcount;
7803 PL_lastgotoprobe = Nullop;
7804 PL_dumpindent = proto_perl->Tdumpindent;
7806 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
7807 PL_sortstash = hv_dup(proto_perl->Tsortstash);
7808 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
7809 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
7810 PL_sortcxix = proto_perl->Tsortcxix;
7811 PL_efloatbuf = Nullch; /* reinits on demand */
7812 PL_efloatsize = 0; /* reinits on demand */
7816 PL_screamfirst = NULL;
7817 PL_screamnext = NULL;
7818 PL_maxscream = -1; /* reinits on demand */
7819 PL_lastscream = Nullsv;
7821 PL_watchaddr = NULL;
7822 PL_watchok = Nullch;
7824 PL_regdummy = proto_perl->Tregdummy;
7825 PL_regcomp_parse = Nullch;
7826 PL_regxend = Nullch;
7827 PL_regcode = (regnode*)NULL;
7830 PL_regprecomp = Nullch;
7835 PL_seen_zerolen = 0;
7837 PL_regcomp_rx = (regexp*)NULL;
7839 PL_colorset = 0; /* reinits PL_colors[] */
7840 /*PL_colors[6] = {0,0,0,0,0,0};*/
7841 PL_reg_whilem_seen = 0;
7842 PL_reginput = Nullch;
7845 PL_regstartp = (I32*)NULL;
7846 PL_regendp = (I32*)NULL;
7847 PL_reglastparen = (U32*)NULL;
7848 PL_regtill = Nullch;
7850 PL_reg_start_tmp = (char**)NULL;
7851 PL_reg_start_tmpl = 0;
7852 PL_regdata = (struct reg_data*)NULL;
7855 PL_reg_eval_set = 0;
7857 PL_regprogram = (regnode*)NULL;
7859 PL_regcc = (CURCUR*)NULL;
7860 PL_reg_call_cc = (struct re_cc_state*)NULL;
7861 PL_reg_re = (regexp*)NULL;
7862 PL_reg_ganch = Nullch;
7864 PL_reg_magic = (MAGIC*)NULL;
7866 PL_reg_oldcurpm = (PMOP*)NULL;
7867 PL_reg_curpm = (PMOP*)NULL;
7868 PL_reg_oldsaved = Nullch;
7869 PL_reg_oldsavedlen = 0;
7871 PL_reg_leftiter = 0;
7872 PL_reg_poscache = Nullch;
7873 PL_reg_poscache_size= 0;
7875 /* RE engine - function pointers */
7876 PL_regcompp = proto_perl->Tregcompp;
7877 PL_regexecp = proto_perl->Tregexecp;
7878 PL_regint_start = proto_perl->Tregint_start;
7879 PL_regint_string = proto_perl->Tregint_string;
7880 PL_regfree = proto_perl->Tregfree;
7882 PL_reginterp_cnt = 0;
7883 PL_reg_starttry = 0;
7886 return (PerlInterpreter*)pPerl;
7892 #else /* !USE_ITHREADS */
7898 #endif /* USE_ITHREADS */
7901 do_report_used(pTHXo_ SV *sv)
7903 if (SvTYPE(sv) != SVTYPEMASK) {
7904 PerlIO_printf(Perl_debug_log, "****\n");
7910 do_clean_objs(pTHXo_ SV *sv)
7914 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
7915 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
7921 /* XXX Might want to check arrays, etc. */
7924 #ifndef DISABLE_DESTRUCTOR_KLUDGE
7926 do_clean_named_objs(pTHXo_ SV *sv)
7928 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
7929 if ( SvOBJECT(GvSV(sv)) ||
7930 GvAV(sv) && SvOBJECT(GvAV(sv)) ||
7931 GvHV(sv) && SvOBJECT(GvHV(sv)) ||
7932 GvIO(sv) && SvOBJECT(GvIO(sv)) ||
7933 GvCV(sv) && SvOBJECT(GvCV(sv)) )
7935 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
7943 do_clean_all(pTHXo_ SV *sv)
7945 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
7946 SvFLAGS(sv) |= SVf_BREAK;