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);
29 * "A time to plant, and a time to uproot what was planted..."
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
40 /* sv_mutex must be held while calling uproot_SV() */
41 #define uproot_SV(p) \
44 PL_sv_root = (SV*)SvANY(p); \
66 if (PL_debug & 32768) \
76 if (PL_debug & 32768) {
81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
83 svend = &sva[SvREFCNT(sva)];
84 if (p >= sv && p < svend)
88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
90 "Attempt to free non-arena SV: 0x%"UVxf,
98 #else /* ! DEBUGGING */
100 #define del_SV(p) plant_SV(p)
102 #endif /* DEBUGGING */
105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
110 Zero(ptr, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
197 XPV *arena, *arenanext;
199 /* Free arenas here, but be careful about fake ones. (We assume
200 contiguity of the fake ones with the corresponding real ones.) */
202 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
203 svanext = (SV*) SvANY(sva);
204 while (svanext && SvFAKE(svanext))
205 svanext = (SV*) SvANY(svanext);
208 Safefree((void *)sva);
211 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
212 arenanext = (XPV*)arena->xpv_pv;
215 PL_xiv_arenaroot = 0;
217 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
218 arenanext = (XPV*)arena->xpv_pv;
221 PL_xnv_arenaroot = 0;
223 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
224 arenanext = (XPV*)arena->xpv_pv;
227 PL_xrv_arenaroot = 0;
229 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
230 arenanext = (XPV*)arena->xpv_pv;
233 PL_xpv_arenaroot = 0;
235 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
236 arenanext = (XPV*)arena->xpv_pv;
239 PL_xpviv_arenaroot = 0;
241 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
242 arenanext = (XPV*)arena->xpv_pv;
245 PL_xpvnv_arenaroot = 0;
247 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
248 arenanext = (XPV*)arena->xpv_pv;
251 PL_xpvcv_arenaroot = 0;
253 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
254 arenanext = (XPV*)arena->xpv_pv;
257 PL_xpvav_arenaroot = 0;
259 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
260 arenanext = (XPV*)arena->xpv_pv;
263 PL_xpvhv_arenaroot = 0;
265 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
266 arenanext = (XPV*)arena->xpv_pv;
269 PL_xpvmg_arenaroot = 0;
271 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
272 arenanext = (XPV*)arena->xpv_pv;
275 PL_xpvlv_arenaroot = 0;
277 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
278 arenanext = (XPV*)arena->xpv_pv;
281 PL_xpvbm_arenaroot = 0;
283 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
284 arenanext = (XPV*)arena->xpv_pv;
290 Safefree(PL_nice_chunk);
291 PL_nice_chunk = Nullch;
292 PL_nice_chunk_size = 0;
298 Perl_report_uninit(pTHX)
301 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
302 " in ", PL_op_desc[PL_op->op_type]);
304 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
316 * See comment in more_xiv() -- RAM.
318 PL_xiv_root = *(IV**)xiv;
320 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
324 S_del_xiv(pTHX_ XPVIV *p)
326 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
328 *(IV**)xiv = PL_xiv_root;
339 New(705, ptr, 1008/sizeof(XPV), XPV);
340 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
341 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
344 xivend = &xiv[1008 / sizeof(IV) - 1];
345 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
347 while (xiv < xivend) {
348 *(IV**)xiv = (IV *)(xiv + 1);
362 PL_xnv_root = *(NV**)xnv;
364 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
368 S_del_xnv(pTHX_ XPVNV *p)
370 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
372 *(NV**)xnv = PL_xnv_root;
383 New(711, ptr, 1008/sizeof(XPV), XPV);
384 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
385 PL_xnv_arenaroot = ptr;
388 xnvend = &xnv[1008 / sizeof(NV) - 1];
389 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
391 while (xnv < xnvend) {
392 *(NV**)xnv = (NV*)(xnv + 1);
406 PL_xrv_root = (XRV*)xrv->xrv_rv;
412 S_del_xrv(pTHX_ XRV *p)
415 p->xrv_rv = (SV*)PL_xrv_root;
424 register XRV* xrvend;
426 New(712, ptr, 1008/sizeof(XPV), XPV);
427 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
428 PL_xrv_arenaroot = ptr;
431 xrvend = &xrv[1008 / sizeof(XRV) - 1];
432 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
434 while (xrv < xrvend) {
435 xrv->xrv_rv = (SV*)(xrv + 1);
449 PL_xpv_root = (XPV*)xpv->xpv_pv;
455 S_del_xpv(pTHX_ XPV *p)
458 p->xpv_pv = (char*)PL_xpv_root;
467 register XPV* xpvend;
468 New(713, xpv, 1008/sizeof(XPV), XPV);
469 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
470 PL_xpv_arenaroot = xpv;
472 xpvend = &xpv[1008 / sizeof(XPV) - 1];
474 while (xpv < xpvend) {
475 xpv->xpv_pv = (char*)(xpv + 1);
488 xpviv = PL_xpviv_root;
489 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
495 S_del_xpviv(pTHX_ XPVIV *p)
498 p->xpv_pv = (char*)PL_xpviv_root;
506 register XPVIV* xpviv;
507 register XPVIV* xpvivend;
508 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
509 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
510 PL_xpviv_arenaroot = xpviv;
512 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
513 PL_xpviv_root = ++xpviv;
514 while (xpviv < xpvivend) {
515 xpviv->xpv_pv = (char*)(xpviv + 1);
528 xpvnv = PL_xpvnv_root;
529 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
535 S_del_xpvnv(pTHX_ XPVNV *p)
538 p->xpv_pv = (char*)PL_xpvnv_root;
546 register XPVNV* xpvnv;
547 register XPVNV* xpvnvend;
548 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
549 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
550 PL_xpvnv_arenaroot = xpvnv;
552 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
553 PL_xpvnv_root = ++xpvnv;
554 while (xpvnv < xpvnvend) {
555 xpvnv->xpv_pv = (char*)(xpvnv + 1);
568 xpvcv = PL_xpvcv_root;
569 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
575 S_del_xpvcv(pTHX_ XPVCV *p)
578 p->xpv_pv = (char*)PL_xpvcv_root;
586 register XPVCV* xpvcv;
587 register XPVCV* xpvcvend;
588 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
589 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
590 PL_xpvcv_arenaroot = xpvcv;
592 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
593 PL_xpvcv_root = ++xpvcv;
594 while (xpvcv < xpvcvend) {
595 xpvcv->xpv_pv = (char*)(xpvcv + 1);
608 xpvav = PL_xpvav_root;
609 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
615 S_del_xpvav(pTHX_ XPVAV *p)
618 p->xav_array = (char*)PL_xpvav_root;
626 register XPVAV* xpvav;
627 register XPVAV* xpvavend;
628 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
629 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
630 PL_xpvav_arenaroot = xpvav;
632 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
633 PL_xpvav_root = ++xpvav;
634 while (xpvav < xpvavend) {
635 xpvav->xav_array = (char*)(xpvav + 1);
638 xpvav->xav_array = 0;
648 xpvhv = PL_xpvhv_root;
649 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
655 S_del_xpvhv(pTHX_ XPVHV *p)
658 p->xhv_array = (char*)PL_xpvhv_root;
666 register XPVHV* xpvhv;
667 register XPVHV* xpvhvend;
668 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
669 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
670 PL_xpvhv_arenaroot = xpvhv;
672 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
673 PL_xpvhv_root = ++xpvhv;
674 while (xpvhv < xpvhvend) {
675 xpvhv->xhv_array = (char*)(xpvhv + 1);
678 xpvhv->xhv_array = 0;
688 xpvmg = PL_xpvmg_root;
689 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
695 S_del_xpvmg(pTHX_ XPVMG *p)
698 p->xpv_pv = (char*)PL_xpvmg_root;
706 register XPVMG* xpvmg;
707 register XPVMG* xpvmgend;
708 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
709 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
710 PL_xpvmg_arenaroot = xpvmg;
712 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
713 PL_xpvmg_root = ++xpvmg;
714 while (xpvmg < xpvmgend) {
715 xpvmg->xpv_pv = (char*)(xpvmg + 1);
728 xpvlv = PL_xpvlv_root;
729 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
735 S_del_xpvlv(pTHX_ XPVLV *p)
738 p->xpv_pv = (char*)PL_xpvlv_root;
746 register XPVLV* xpvlv;
747 register XPVLV* xpvlvend;
748 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
749 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
750 PL_xpvlv_arenaroot = xpvlv;
752 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
753 PL_xpvlv_root = ++xpvlv;
754 while (xpvlv < xpvlvend) {
755 xpvlv->xpv_pv = (char*)(xpvlv + 1);
768 xpvbm = PL_xpvbm_root;
769 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
775 S_del_xpvbm(pTHX_ XPVBM *p)
778 p->xpv_pv = (char*)PL_xpvbm_root;
786 register XPVBM* xpvbm;
787 register XPVBM* xpvbmend;
788 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
789 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
790 PL_xpvbm_arenaroot = xpvbm;
792 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
793 PL_xpvbm_root = ++xpvbm;
794 while (xpvbm < xpvbmend) {
795 xpvbm->xpv_pv = (char*)(xpvbm + 1);
802 # define my_safemalloc(s) (void*)safexmalloc(717,s)
803 # define my_safefree(p) safexfree((char*)p)
805 # define my_safemalloc(s) (void*)safemalloc(s)
806 # define my_safefree(p) safefree((char*)p)
811 #define new_XIV() my_safemalloc(sizeof(XPVIV))
812 #define del_XIV(p) my_safefree(p)
814 #define new_XNV() my_safemalloc(sizeof(XPVNV))
815 #define del_XNV(p) my_safefree(p)
817 #define new_XRV() my_safemalloc(sizeof(XRV))
818 #define del_XRV(p) my_safefree(p)
820 #define new_XPV() my_safemalloc(sizeof(XPV))
821 #define del_XPV(p) my_safefree(p)
823 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
824 #define del_XPVIV(p) my_safefree(p)
826 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
827 #define del_XPVNV(p) my_safefree(p)
829 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
830 #define del_XPVCV(p) my_safefree(p)
832 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
833 #define del_XPVAV(p) my_safefree(p)
835 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
836 #define del_XPVHV(p) my_safefree(p)
838 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
839 #define del_XPVMG(p) my_safefree(p)
841 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
842 #define del_XPVLV(p) my_safefree(p)
844 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
845 #define del_XPVBM(p) my_safefree(p)
849 #define new_XIV() (void*)new_xiv()
850 #define del_XIV(p) del_xiv((XPVIV*) p)
852 #define new_XNV() (void*)new_xnv()
853 #define del_XNV(p) del_xnv((XPVNV*) p)
855 #define new_XRV() (void*)new_xrv()
856 #define del_XRV(p) del_xrv((XRV*) p)
858 #define new_XPV() (void*)new_xpv()
859 #define del_XPV(p) del_xpv((XPV *)p)
861 #define new_XPVIV() (void*)new_xpviv()
862 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
864 #define new_XPVNV() (void*)new_xpvnv()
865 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
867 #define new_XPVCV() (void*)new_xpvcv()
868 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
870 #define new_XPVAV() (void*)new_xpvav()
871 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
873 #define new_XPVHV() (void*)new_xpvhv()
874 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
876 #define new_XPVMG() (void*)new_xpvmg()
877 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
879 #define new_XPVLV() (void*)new_xpvlv()
880 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
882 #define new_XPVBM() (void*)new_xpvbm()
883 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
887 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
888 #define del_XPVGV(p) my_safefree(p)
890 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
891 #define del_XPVFM(p) my_safefree(p)
893 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
894 #define del_XPVIO(p) my_safefree(p)
897 =for apidoc sv_upgrade
899 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
906 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
916 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
920 if (SvTYPE(sv) == mt)
926 switch (SvTYPE(sv)) {
947 else if (mt < SVt_PVIV)
964 pv = (char*)SvRV(sv);
984 else if (mt == SVt_NV)
995 del_XPVIV(SvANY(sv));
1005 del_XPVNV(SvANY(sv));
1013 magic = SvMAGIC(sv);
1014 stash = SvSTASH(sv);
1015 del_XPVMG(SvANY(sv));
1018 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1023 Perl_croak(aTHX_ "Can't upgrade to undef");
1025 SvANY(sv) = new_XIV();
1029 SvANY(sv) = new_XNV();
1033 SvANY(sv) = new_XRV();
1037 SvANY(sv) = new_XPV();
1043 SvANY(sv) = new_XPVIV();
1053 SvANY(sv) = new_XPVNV();
1061 SvANY(sv) = new_XPVMG();
1067 SvMAGIC(sv) = magic;
1068 SvSTASH(sv) = stash;
1071 SvANY(sv) = new_XPVLV();
1077 SvMAGIC(sv) = magic;
1078 SvSTASH(sv) = stash;
1085 SvANY(sv) = new_XPVAV();
1093 SvMAGIC(sv) = magic;
1094 SvSTASH(sv) = stash;
1100 SvANY(sv) = new_XPVHV();
1108 SvMAGIC(sv) = magic;
1109 SvSTASH(sv) = stash;
1116 SvANY(sv) = new_XPVCV();
1117 Zero(SvANY(sv), 1, XPVCV);
1123 SvMAGIC(sv) = magic;
1124 SvSTASH(sv) = stash;
1127 SvANY(sv) = new_XPVGV();
1133 SvMAGIC(sv) = magic;
1134 SvSTASH(sv) = stash;
1142 SvANY(sv) = new_XPVBM();
1148 SvMAGIC(sv) = magic;
1149 SvSTASH(sv) = stash;
1155 SvANY(sv) = new_XPVFM();
1156 Zero(SvANY(sv), 1, XPVFM);
1162 SvMAGIC(sv) = magic;
1163 SvSTASH(sv) = stash;
1166 SvANY(sv) = new_XPVIO();
1167 Zero(SvANY(sv), 1, XPVIO);
1173 SvMAGIC(sv) = magic;
1174 SvSTASH(sv) = stash;
1175 IoPAGE_LEN(sv) = 60;
1178 SvFLAGS(sv) &= ~SVTYPEMASK;
1184 Perl_sv_backoff(pTHX_ register SV *sv)
1188 char *s = SvPVX(sv);
1189 SvLEN(sv) += SvIVX(sv);
1190 SvPVX(sv) -= SvIVX(sv);
1192 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1194 SvFLAGS(sv) &= ~SVf_OOK;
1201 Expands the character buffer in the SV. This will use C<sv_unref> and will
1202 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1209 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1213 #ifdef HAS_64K_LIMIT
1214 if (newlen >= 0x10000) {
1215 PerlIO_printf(Perl_debug_log,
1216 "Allocation too large: %"UVxf"\n", (UV)newlen);
1219 #endif /* HAS_64K_LIMIT */
1222 if (SvTYPE(sv) < SVt_PV) {
1223 sv_upgrade(sv, SVt_PV);
1226 else if (SvOOK(sv)) { /* pv is offset? */
1229 if (newlen > SvLEN(sv))
1230 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1231 #ifdef HAS_64K_LIMIT
1232 if (newlen >= 0x10000)
1238 if (newlen > SvLEN(sv)) { /* need more room? */
1239 if (SvLEN(sv) && s) {
1240 #if defined(MYMALLOC) && !defined(LEAKTEST)
1241 STRLEN l = malloced_size((void*)SvPVX(sv));
1247 Renew(s,newlen,char);
1250 New(703,s,newlen,char);
1252 SvLEN_set(sv, newlen);
1258 =for apidoc sv_setiv
1260 Copies an integer into the given SV. Does not handle 'set' magic. See
1267 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1269 SV_CHECK_THINKFIRST(sv);
1270 switch (SvTYPE(sv)) {
1272 sv_upgrade(sv, SVt_IV);
1275 sv_upgrade(sv, SVt_PVNV);
1279 sv_upgrade(sv, SVt_PVIV);
1288 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1289 PL_op_desc[PL_op->op_type]);
1291 (void)SvIOK_only(sv); /* validate number */
1297 =for apidoc sv_setiv_mg
1299 Like C<sv_setiv>, but also handles 'set' magic.
1305 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1312 =for apidoc sv_setuv
1314 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1321 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1329 =for apidoc sv_setuv_mg
1331 Like C<sv_setuv>, but also handles 'set' magic.
1337 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1344 =for apidoc sv_setnv
1346 Copies a double into the given SV. Does not handle 'set' magic. See
1353 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1355 SV_CHECK_THINKFIRST(sv);
1356 switch (SvTYPE(sv)) {
1359 sv_upgrade(sv, SVt_NV);
1364 sv_upgrade(sv, SVt_PVNV);
1373 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1374 PL_op_name[PL_op->op_type]);
1377 (void)SvNOK_only(sv); /* validate number */
1382 =for apidoc sv_setnv_mg
1384 Like C<sv_setnv>, but also handles 'set' magic.
1390 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1397 S_not_a_number(pTHX_ SV *sv)
1402 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1403 /* each *s can expand to 4 chars + "...\0",
1404 i.e. need room for 8 chars */
1406 for (s = SvPVX(sv); *s && d < limit; s++) {
1408 if (ch & 128 && !isPRINT_LC(ch)) {
1417 else if (ch == '\r') {
1421 else if (ch == '\f') {
1425 else if (ch == '\\') {
1429 else if (isPRINT_LC(ch))
1444 Perl_warner(aTHX_ WARN_NUMERIC,
1445 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1446 PL_op_desc[PL_op->op_type]);
1448 Perl_warner(aTHX_ WARN_NUMERIC,
1449 "Argument \"%s\" isn't numeric", tmpbuf);
1452 /* the number can be converted to integer with atol() or atoll() */
1453 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1454 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1455 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1456 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1457 #define IS_NUMBER_INFINITY 0x10 /* this is big */
1459 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1460 until proven guilty, assume that things are not that bad... */
1463 Perl_sv_2iv(pTHX_ register SV *sv)
1467 if (SvGMAGICAL(sv)) {
1472 return I_V(SvNVX(sv));
1474 if (SvPOKp(sv) && SvLEN(sv))
1477 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1478 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1484 if (SvTHINKFIRST(sv)) {
1487 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1488 (SvRV(tmpstr) != SvRV(sv)))
1489 return SvIV(tmpstr);
1490 return PTR2IV(SvRV(sv));
1492 if (SvREADONLY(sv) && SvFAKE(sv)) {
1493 sv_force_normal(sv);
1495 if (SvREADONLY(sv) && !SvOK(sv)) {
1496 if (ckWARN(WARN_UNINITIALIZED))
1503 return (IV)(SvUVX(sv));
1510 /* We can cache the IV/UV value even if it not good enough
1511 * to reconstruct NV, since the conversion to PV will prefer
1515 if (SvTYPE(sv) == SVt_NV)
1516 sv_upgrade(sv, SVt_PVNV);
1519 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1520 SvIVX(sv) = I_V(SvNVX(sv));
1522 SvUVX(sv) = U_V(SvNVX(sv));
1525 DEBUG_c(PerlIO_printf(Perl_debug_log,
1526 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1530 return (IV)SvUVX(sv);
1533 else if (SvPOKp(sv) && SvLEN(sv)) {
1534 I32 numtype = looks_like_number(sv);
1536 /* We want to avoid a possible problem when we cache an IV which
1537 may be later translated to an NV, and the resulting NV is not
1538 the translation of the initial data.
1540 This means that if we cache such an IV, we need to cache the
1541 NV as well. Moreover, we trade speed for space, and do not
1542 cache the NV if not needed.
1544 if (numtype & IS_NUMBER_NOT_IV) {
1545 /* May be not an integer. Need to cache NV if we cache IV
1546 * - otherwise future conversion to NV will be wrong. */
1549 d = Atof(SvPVX(sv));
1551 if (SvTYPE(sv) < SVt_PVNV)
1552 sv_upgrade(sv, SVt_PVNV);
1556 #if defined(USE_LONG_DOUBLE)
1557 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1558 PTR2UV(sv), SvNVX(sv)));
1560 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1561 PTR2UV(sv), SvNVX(sv)));
1563 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1564 SvIVX(sv) = I_V(SvNVX(sv));
1566 SvUVX(sv) = U_V(SvNVX(sv));
1571 else { /* The NV may be reconstructed from IV - safe to cache IV,
1572 which may be calculated by atol(). */
1573 if (SvTYPE(sv) < SVt_PVIV)
1574 sv_upgrade(sv, SVt_PVIV);
1576 SvIVX(sv) = Atol(SvPVX(sv));
1577 if (! numtype && ckWARN(WARN_NUMERIC))
1582 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1584 if (SvTYPE(sv) < SVt_IV)
1585 /* Typically the caller expects that sv_any is not NULL now. */
1586 sv_upgrade(sv, SVt_IV);
1589 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1590 PTR2UV(sv),SvIVX(sv)));
1591 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1595 Perl_sv_2uv(pTHX_ register SV *sv)
1599 if (SvGMAGICAL(sv)) {
1604 return U_V(SvNVX(sv));
1605 if (SvPOKp(sv) && SvLEN(sv))
1608 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1609 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1615 if (SvTHINKFIRST(sv)) {
1618 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1619 (SvRV(tmpstr) != SvRV(sv)))
1620 return SvUV(tmpstr);
1621 return PTR2UV(SvRV(sv));
1623 if (SvREADONLY(sv) && !SvOK(sv)) {
1624 if (ckWARN(WARN_UNINITIALIZED))
1634 return (UV)SvIVX(sv);
1638 /* We can cache the IV/UV value even if it not good enough
1639 * to reconstruct NV, since the conversion to PV will prefer
1642 if (SvTYPE(sv) == SVt_NV)
1643 sv_upgrade(sv, SVt_PVNV);
1645 if (SvNVX(sv) >= -0.5) {
1647 SvUVX(sv) = U_V(SvNVX(sv));
1650 SvIVX(sv) = I_V(SvNVX(sv));
1652 DEBUG_c(PerlIO_printf(Perl_debug_log,
1653 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1656 (IV)(UV)SvIVX(sv)));
1657 return (UV)SvIVX(sv);
1660 else if (SvPOKp(sv) && SvLEN(sv)) {
1661 I32 numtype = looks_like_number(sv);
1663 /* We want to avoid a possible problem when we cache a UV which
1664 may be later translated to an NV, and the resulting NV is not
1665 the translation of the initial data.
1667 This means that if we cache such a UV, we need to cache the
1668 NV as well. Moreover, we trade speed for space, and do not
1669 cache the NV if not needed.
1671 if (numtype & IS_NUMBER_NOT_IV) {
1672 /* May be not an integer. Need to cache NV if we cache IV
1673 * - otherwise future conversion to NV will be wrong. */
1676 d = Atof(SvPVX(sv));
1678 if (SvTYPE(sv) < SVt_PVNV)
1679 sv_upgrade(sv, SVt_PVNV);
1683 #if defined(USE_LONG_DOUBLE)
1684 DEBUG_c(PerlIO_printf(Perl_debug_log,
1685 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1686 PTR2UV(sv), SvNVX(sv)));
1688 DEBUG_c(PerlIO_printf(Perl_debug_log,
1689 "0x%"UVxf" 2nv(%g)\n",
1690 PTR2UV(sv), SvNVX(sv)));
1692 if (SvNVX(sv) < -0.5) {
1693 SvIVX(sv) = I_V(SvNVX(sv));
1696 SvUVX(sv) = U_V(SvNVX(sv));
1700 else if (numtype & IS_NUMBER_NEG) {
1701 /* The NV may be reconstructed from IV - safe to cache IV,
1702 which may be calculated by atol(). */
1703 if (SvTYPE(sv) == SVt_PV)
1704 sv_upgrade(sv, SVt_PVIV);
1706 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1708 else if (numtype) { /* Non-negative */
1709 /* The NV may be reconstructed from UV - safe to cache UV,
1710 which may be calculated by strtoul()/atol. */
1711 if (SvTYPE(sv) == SVt_PV)
1712 sv_upgrade(sv, SVt_PVIV);
1714 (void)SvIsUV_on(sv);
1716 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1717 #else /* no atou(), but we know the number fits into IV... */
1718 /* The only problem may be if it is negative... */
1719 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1722 else { /* Not a number. Cache 0. */
1723 if (SvTYPE(sv) < SVt_PVIV)
1724 sv_upgrade(sv, SVt_PVIV);
1726 (void)SvIsUV_on(sv);
1727 SvUVX(sv) = 0; /* We assume that 0s have the
1728 same bitmap in IV and UV. */
1729 if (ckWARN(WARN_NUMERIC))
1734 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1735 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1738 if (SvTYPE(sv) < SVt_IV)
1739 /* Typically the caller expects that sv_any is not NULL now. */
1740 sv_upgrade(sv, SVt_IV);
1744 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1745 PTR2UV(sv),SvUVX(sv)));
1746 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1750 Perl_sv_2nv(pTHX_ register SV *sv)
1754 if (SvGMAGICAL(sv)) {
1758 if (SvPOKp(sv) && SvLEN(sv)) {
1759 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1761 return Atof(SvPVX(sv));
1765 return (NV)SvUVX(sv);
1767 return (NV)SvIVX(sv);
1770 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1771 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1777 if (SvTHINKFIRST(sv)) {
1780 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1781 (SvRV(tmpstr) != SvRV(sv)))
1782 return SvNV(tmpstr);
1783 return PTR2NV(SvRV(sv));
1785 if (SvREADONLY(sv) && !SvOK(sv)) {
1786 if (ckWARN(WARN_UNINITIALIZED))
1791 if (SvTYPE(sv) < SVt_NV) {
1792 if (SvTYPE(sv) == SVt_IV)
1793 sv_upgrade(sv, SVt_PVNV);
1795 sv_upgrade(sv, SVt_NV);
1796 #if defined(USE_LONG_DOUBLE)
1798 STORE_NUMERIC_LOCAL_SET_STANDARD();
1799 PerlIO_printf(Perl_debug_log,
1800 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1801 PTR2UV(sv), SvNVX(sv));
1802 RESTORE_NUMERIC_LOCAL();
1806 STORE_NUMERIC_LOCAL_SET_STANDARD();
1807 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1808 PTR2UV(sv), SvNVX(sv));
1809 RESTORE_NUMERIC_LOCAL();
1813 else if (SvTYPE(sv) < SVt_PVNV)
1814 sv_upgrade(sv, SVt_PVNV);
1816 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1818 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1820 else if (SvPOKp(sv) && SvLEN(sv)) {
1821 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1823 SvNVX(sv) = Atof(SvPVX(sv));
1826 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1828 if (SvTYPE(sv) < SVt_NV)
1829 /* Typically the caller expects that sv_any is not NULL now. */
1830 sv_upgrade(sv, SVt_NV);
1834 #if defined(USE_LONG_DOUBLE)
1836 STORE_NUMERIC_LOCAL_SET_STANDARD();
1837 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1838 PTR2UV(sv), SvNVX(sv));
1839 RESTORE_NUMERIC_LOCAL();
1843 STORE_NUMERIC_LOCAL_SET_STANDARD();
1844 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1845 PTR2UV(sv), SvNVX(sv));
1846 RESTORE_NUMERIC_LOCAL();
1853 S_asIV(pTHX_ SV *sv)
1855 I32 numtype = looks_like_number(sv);
1858 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1859 return Atol(SvPVX(sv));
1861 if (ckWARN(WARN_NUMERIC))
1864 d = Atof(SvPVX(sv));
1869 S_asUV(pTHX_ SV *sv)
1871 I32 numtype = looks_like_number(sv);
1874 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1875 return Strtoul(SvPVX(sv), Null(char**), 10);
1878 if (ckWARN(WARN_NUMERIC))
1881 return U_V(Atof(SvPVX(sv)));
1885 * Returns a combination of (advisory only - can get false negatives)
1886 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1888 * 0 if does not look like number.
1890 * In fact possible values are 0 and
1891 * IS_NUMBER_TO_INT_BY_ATOL 123
1892 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1893 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1894 * IS_NUMBER_INFINITY
1895 * with a possible addition of IS_NUMBER_NEG.
1899 =for apidoc looks_like_number
1901 Test if an the content of an SV looks like a number (or is a
1908 Perl_looks_like_number(pTHX_ SV *sv)
1911 register char *send;
1912 register char *sbegin;
1913 register char *nbegin;
1922 else if (SvPOKp(sv))
1923 sbegin = SvPV(sv, len);
1926 send = sbegin + len;
1933 numtype = IS_NUMBER_NEG;
1940 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1941 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1945 /* next must be digit or the radix separator or beginning of infinity */
1949 } while (isDIGIT(*s));
1951 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1952 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1954 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1957 #ifdef USE_LOCALE_NUMERIC
1958 || IS_NUMERIC_RADIX(*s)
1962 numtype |= IS_NUMBER_NOT_IV;
1963 while (isDIGIT(*s)) /* optional digits after the radix */
1968 #ifdef USE_LOCALE_NUMERIC
1969 || IS_NUMERIC_RADIX(*s)
1973 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1974 /* no digits before the radix means we need digits after it */
1978 } while (isDIGIT(*s));
1983 else if (*s == 'I' || *s == 'i') {
1984 s++; if (*s != 'N' && *s != 'n') return 0;
1985 s++; if (*s != 'F' && *s != 'f') return 0;
1986 s++; if (*s == 'I' || *s == 'i') {
1987 s++; if (*s != 'N' && *s != 'n') return 0;
1988 s++; if (*s != 'I' && *s != 'i') return 0;
1989 s++; if (*s != 'T' && *s != 't') return 0;
1990 s++; if (*s != 'Y' && *s != 'y') return 0;
1999 numtype = IS_NUMBER_INFINITY;
2001 /* we can have an optional exponent part */
2002 if (*s == 'e' || *s == 'E') {
2003 numtype &= ~IS_NUMBER_NEG;
2004 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
2006 if (*s == '+' || *s == '-')
2011 } while (isDIGIT(*s));
2021 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2022 return IS_NUMBER_TO_INT_BY_ATOL;
2027 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2030 return sv_2pv(sv, &n_a);
2033 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2035 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2037 char *ptr = buf + TYPE_CHARS(UV);
2051 *--ptr = '0' + (uv % 10);
2060 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2065 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2066 char *tmpbuf = tbuf;
2072 if (SvGMAGICAL(sv)) {
2080 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2082 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2087 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2092 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2093 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2100 if (SvTHINKFIRST(sv)) {
2103 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2104 (SvRV(tmpstr) != SvRV(sv)))
2105 return SvPV(tmpstr,*lp);
2112 switch (SvTYPE(sv)) {
2114 if ( ((SvFLAGS(sv) &
2115 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2116 == (SVs_OBJECT|SVs_RMG))
2117 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2118 && (mg = mg_find(sv, 'r'))) {
2119 regexp *re = (regexp *)mg->mg_obj;
2122 char *fptr = "msix";
2127 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2129 while((ch = *fptr++)) {
2131 reflags[left++] = ch;
2134 reflags[right--] = ch;
2139 reflags[left] = '-';
2143 mg->mg_len = re->prelen + 4 + left;
2144 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2145 Copy("(?", mg->mg_ptr, 2, char);
2146 Copy(reflags, mg->mg_ptr+2, left, char);
2147 Copy(":", mg->mg_ptr+left+2, 1, char);
2148 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2149 mg->mg_ptr[mg->mg_len - 1] = ')';
2150 mg->mg_ptr[mg->mg_len] = 0;
2152 PL_reginterp_cnt += re->program[0].next_off;
2164 case SVt_PVBM: if (SvROK(sv))
2167 s = "SCALAR"; break;
2168 case SVt_PVLV: s = "LVALUE"; break;
2169 case SVt_PVAV: s = "ARRAY"; break;
2170 case SVt_PVHV: s = "HASH"; break;
2171 case SVt_PVCV: s = "CODE"; break;
2172 case SVt_PVGV: s = "GLOB"; break;
2173 case SVt_PVFM: s = "FORMAT"; break;
2174 case SVt_PVIO: s = "IO"; break;
2175 default: s = "UNKNOWN"; break;
2179 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2182 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2188 if (SvREADONLY(sv) && !SvOK(sv)) {
2189 if (ckWARN(WARN_UNINITIALIZED))
2195 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2196 /* XXXX 64-bit? IV may have better precision... */
2197 /* I tried changing this to be 64-bit-aware and
2198 * the t/op/numconvert.t became very, very, angry.
2200 if (SvTYPE(sv) < SVt_PVNV)
2201 sv_upgrade(sv, SVt_PVNV);
2202 /* The +20 is pure guesswork. Configure test needed. --jhi */
2203 SvGROW(sv, NV_DIG + 20);
2205 olderrno = errno; /* some Xenix systems wipe out errno here */
2207 if (SvNVX(sv) == 0.0)
2208 (void)strcpy(s,"0");
2212 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2215 #ifdef FIXNEGATIVEZERO
2216 if (*s == '-' && s[1] == '0' && !s[2])
2225 else if (SvIOKp(sv)) {
2226 U32 isIOK = SvIOK(sv);
2227 U32 isUIOK = SvIsUV(sv);
2228 char buf[TYPE_CHARS(UV)];
2231 if (SvTYPE(sv) < SVt_PVIV)
2232 sv_upgrade(sv, SVt_PVIV);
2234 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2236 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2237 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2238 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2239 SvCUR_set(sv, ebuf - ptr);
2251 if (ckWARN(WARN_UNINITIALIZED)
2252 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2255 if (SvTYPE(sv) < SVt_PV)
2256 /* Typically the caller expects that sv_any is not NULL now. */
2257 sv_upgrade(sv, SVt_PV);
2260 *lp = s - SvPVX(sv);
2263 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2264 PTR2UV(sv),SvPVX(sv)));
2268 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2269 /* Sneaky stuff here */
2273 tsv = newSVpv(tmpbuf, 0);
2289 len = strlen(tmpbuf);
2291 #ifdef FIXNEGATIVEZERO
2292 if (len == 2 && t[0] == '-' && t[1] == '0') {
2297 (void)SvUPGRADE(sv, SVt_PV);
2299 s = SvGROW(sv, len + 1);
2308 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2311 return sv_2pvbyte(sv, &n_a);
2315 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2317 return sv_2pv(sv,lp);
2321 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2324 return sv_2pvutf8(sv, &n_a);
2328 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2330 sv_utf8_upgrade(sv);
2331 return sv_2pv(sv,lp);
2334 /* This function is only called on magical items */
2336 Perl_sv_2bool(pTHX_ register SV *sv)
2345 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2346 (SvRV(tmpsv) != SvRV(sv)))
2347 return SvTRUE(tmpsv);
2348 return SvRV(sv) != 0;
2351 register XPV* Xpvtmp;
2352 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2353 (*Xpvtmp->xpv_pv > '0' ||
2354 Xpvtmp->xpv_cur > 1 ||
2355 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2362 return SvIVX(sv) != 0;
2365 return SvNVX(sv) != 0.0;
2373 =for apidoc sv_utf8_upgrade
2375 Convert the PV of an SV to its UTF8-encoded form.
2381 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2386 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2389 /* This function could be much more efficient if we had a FLAG in SVs
2390 * to signal if there are any hibit chars in the PV.
2392 for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++)
2397 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
2398 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2399 SvCUR(sv) = len - 1;
2400 SvLEN(sv) = len; /* No longer know the real size. */
2402 Safefree(s); /* No longer using what was there before. */
2407 =for apidoc sv_utf8_downgrade
2409 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2410 This may not be possible if the PV contains non-byte encoding characters;
2411 if this is the case, either returns false or, if C<fail_ok> is not
2418 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2420 if (SvPOK(sv) && SvUTF8(sv)) {
2422 char *c = SvPVX(sv);
2423 STRLEN len = SvCUR(sv);
2425 if (!utf8_to_bytes((U8*)c, &len)) {
2430 Perl_croak(aTHX_ "Wide character in %s",
2431 PL_op_desc[PL_op->op_type]);
2433 Perl_croak(aTHX_ "Wide character");
2445 =for apidoc sv_utf8_encode
2447 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2448 flag so that it looks like bytes again. Nothing calls this.
2454 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2456 sv_utf8_upgrade(sv);
2461 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2465 bool has_utf = FALSE;
2466 if (!sv_utf8_downgrade(sv, TRUE))
2469 /* it is actually just a matter of turning the utf8 flag on, but
2470 * we want to make sure everything inside is valid utf8 first.
2473 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
2476 while (c < SvEND(sv)) {
2487 /* Note: sv_setsv() should not be called with a source string that needs
2488 * to be reused, since it may destroy the source string if it is marked
2493 =for apidoc sv_setsv
2495 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2496 The source SV may be destroyed if it is mortal. Does not handle 'set'
2497 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2504 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2506 register U32 sflags;
2512 SV_CHECK_THINKFIRST(dstr);
2514 sstr = &PL_sv_undef;
2515 stype = SvTYPE(sstr);
2516 dtype = SvTYPE(dstr);
2520 /* There's a lot of redundancy below but we're going for speed here */
2525 if (dtype != SVt_PVGV) {
2526 (void)SvOK_off(dstr);
2534 sv_upgrade(dstr, SVt_IV);
2537 sv_upgrade(dstr, SVt_PVNV);
2541 sv_upgrade(dstr, SVt_PVIV);
2544 (void)SvIOK_only(dstr);
2545 SvIVX(dstr) = SvIVX(sstr);
2548 if (SvTAINTED(sstr))
2559 sv_upgrade(dstr, SVt_NV);
2564 sv_upgrade(dstr, SVt_PVNV);
2567 SvNVX(dstr) = SvNVX(sstr);
2568 (void)SvNOK_only(dstr);
2569 if (SvTAINTED(sstr))
2577 sv_upgrade(dstr, SVt_RV);
2578 else if (dtype == SVt_PVGV &&
2579 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2582 if (GvIMPORTED(dstr) != GVf_IMPORTED
2583 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2585 GvIMPORTED_on(dstr);
2596 sv_upgrade(dstr, SVt_PV);
2599 if (dtype < SVt_PVIV)
2600 sv_upgrade(dstr, SVt_PVIV);
2603 if (dtype < SVt_PVNV)
2604 sv_upgrade(dstr, SVt_PVNV);
2611 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2612 PL_op_name[PL_op->op_type]);
2614 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2618 if (dtype <= SVt_PVGV) {
2620 if (dtype != SVt_PVGV) {
2621 char *name = GvNAME(sstr);
2622 STRLEN len = GvNAMELEN(sstr);
2623 sv_upgrade(dstr, SVt_PVGV);
2624 sv_magic(dstr, dstr, '*', Nullch, 0);
2625 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2626 GvNAME(dstr) = savepvn(name, len);
2627 GvNAMELEN(dstr) = len;
2628 SvFAKE_on(dstr); /* can coerce to non-glob */
2630 /* ahem, death to those who redefine active sort subs */
2631 else if (PL_curstackinfo->si_type == PERLSI_SORT
2632 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2633 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2635 (void)SvOK_off(dstr);
2636 GvINTRO_off(dstr); /* one-shot flag */
2638 GvGP(dstr) = gp_ref(GvGP(sstr));
2639 if (SvTAINTED(sstr))
2641 if (GvIMPORTED(dstr) != GVf_IMPORTED
2642 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2644 GvIMPORTED_on(dstr);
2652 if (SvGMAGICAL(sstr)) {
2654 if (SvTYPE(sstr) != stype) {
2655 stype = SvTYPE(sstr);
2656 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2660 if (stype == SVt_PVLV)
2661 (void)SvUPGRADE(dstr, SVt_PVNV);
2663 (void)SvUPGRADE(dstr, stype);
2666 sflags = SvFLAGS(sstr);
2668 if (sflags & SVf_ROK) {
2669 if (dtype >= SVt_PV) {
2670 if (dtype == SVt_PVGV) {
2671 SV *sref = SvREFCNT_inc(SvRV(sstr));
2673 int intro = GvINTRO(dstr);
2678 GvINTRO_off(dstr); /* one-shot flag */
2679 Newz(602,gp, 1, GP);
2680 GvGP(dstr) = gp_ref(gp);
2681 GvSV(dstr) = NEWSV(72,0);
2682 GvLINE(dstr) = CopLINE(PL_curcop);
2683 GvEGV(dstr) = (GV*)dstr;
2686 switch (SvTYPE(sref)) {
2689 SAVESPTR(GvAV(dstr));
2691 dref = (SV*)GvAV(dstr);
2692 GvAV(dstr) = (AV*)sref;
2693 if (!GvIMPORTED_AV(dstr)
2694 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2696 GvIMPORTED_AV_on(dstr);
2701 SAVESPTR(GvHV(dstr));
2703 dref = (SV*)GvHV(dstr);
2704 GvHV(dstr) = (HV*)sref;
2705 if (!GvIMPORTED_HV(dstr)
2706 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2708 GvIMPORTED_HV_on(dstr);
2713 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2714 SvREFCNT_dec(GvCV(dstr));
2715 GvCV(dstr) = Nullcv;
2716 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2717 PL_sub_generation++;
2719 SAVESPTR(GvCV(dstr));
2722 dref = (SV*)GvCV(dstr);
2723 if (GvCV(dstr) != (CV*)sref) {
2724 CV* cv = GvCV(dstr);
2726 if (!GvCVGEN((GV*)dstr) &&
2727 (CvROOT(cv) || CvXSUB(cv)))
2730 /* ahem, death to those who redefine
2731 * active sort subs */
2732 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2733 PL_sortcop == CvSTART(cv))
2735 "Can't redefine active sort subroutine %s",
2736 GvENAME((GV*)dstr));
2737 /* Redefining a sub - warning is mandatory if
2738 it was a const and its value changed. */
2739 if (ckWARN(WARN_REDEFINE)
2741 && (!CvCONST((CV*)sref)
2742 || sv_cmp(cv_const_sv(cv),
2743 cv_const_sv((CV*)sref)))))
2745 Perl_warner(aTHX_ WARN_REDEFINE,
2747 ? "Constant subroutine %s redefined"
2748 : "Subroutine %s redefined",
2749 GvENAME((GV*)dstr));
2752 cv_ckproto(cv, (GV*)dstr,
2753 SvPOK(sref) ? SvPVX(sref) : Nullch);
2755 GvCV(dstr) = (CV*)sref;
2756 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2757 GvASSUMECV_on(dstr);
2758 PL_sub_generation++;
2760 if (!GvIMPORTED_CV(dstr)
2761 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2763 GvIMPORTED_CV_on(dstr);
2768 SAVESPTR(GvIOp(dstr));
2770 dref = (SV*)GvIOp(dstr);
2771 GvIOp(dstr) = (IO*)sref;
2775 SAVESPTR(GvFORM(dstr));
2777 dref = (SV*)GvFORM(dstr);
2778 GvFORM(dstr) = (CV*)sref;
2782 SAVESPTR(GvSV(dstr));
2784 dref = (SV*)GvSV(dstr);
2786 if (!GvIMPORTED_SV(dstr)
2787 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2789 GvIMPORTED_SV_on(dstr);
2797 if (SvTAINTED(sstr))
2802 (void)SvOOK_off(dstr); /* backoff */
2804 Safefree(SvPVX(dstr));
2805 SvLEN(dstr)=SvCUR(dstr)=0;
2808 (void)SvOK_off(dstr);
2809 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2811 if (sflags & SVp_NOK) {
2813 SvNVX(dstr) = SvNVX(sstr);
2815 if (sflags & SVp_IOK) {
2816 (void)SvIOK_on(dstr);
2817 SvIVX(dstr) = SvIVX(sstr);
2818 if (sflags & SVf_IVisUV)
2821 if (SvAMAGIC(sstr)) {
2825 else if (sflags & SVp_POK) {
2828 * Check to see if we can just swipe the string. If so, it's a
2829 * possible small lose on short strings, but a big win on long ones.
2830 * It might even be a win on short strings if SvPVX(dstr)
2831 * has to be allocated and SvPVX(sstr) has to be freed.
2834 if (SvTEMP(sstr) && /* slated for free anyway? */
2835 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2836 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
2837 SvLEN(sstr) && /* and really is a string */
2838 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
2840 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2842 SvFLAGS(dstr) &= ~SVf_OOK;
2843 Safefree(SvPVX(dstr) - SvIVX(dstr));
2845 else if (SvLEN(dstr))
2846 Safefree(SvPVX(dstr));
2848 (void)SvPOK_only(dstr);
2849 SvPV_set(dstr, SvPVX(sstr));
2850 SvLEN_set(dstr, SvLEN(sstr));
2851 SvCUR_set(dstr, SvCUR(sstr));
2854 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
2855 SvPV_set(sstr, Nullch);
2860 else { /* have to copy actual string */
2861 STRLEN len = SvCUR(sstr);
2863 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2864 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2865 SvCUR_set(dstr, len);
2866 *SvEND(dstr) = '\0';
2867 (void)SvPOK_only(dstr);
2869 if ((sflags & SVf_UTF8) && !IN_BYTE)
2872 if (sflags & SVp_NOK) {
2874 SvNVX(dstr) = SvNVX(sstr);
2876 if (sflags & SVp_IOK) {
2877 (void)SvIOK_on(dstr);
2878 SvIVX(dstr) = SvIVX(sstr);
2879 if (sflags & SVf_IVisUV)
2883 else if (sflags & SVp_NOK) {
2884 SvNVX(dstr) = SvNVX(sstr);
2885 (void)SvNOK_only(dstr);
2886 if (sflags & SVf_IOK) {
2887 (void)SvIOK_on(dstr);
2888 SvIVX(dstr) = SvIVX(sstr);
2889 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2890 if (sflags & SVf_IVisUV)
2894 else if (sflags & SVp_IOK) {
2895 (void)SvIOK_only(dstr);
2896 SvIVX(dstr) = SvIVX(sstr);
2897 if (sflags & SVf_IVisUV)
2901 if (dtype == SVt_PVGV) {
2902 if (ckWARN(WARN_MISC))
2903 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2906 (void)SvOK_off(dstr);
2908 if (SvTAINTED(sstr))
2913 =for apidoc sv_setsv_mg
2915 Like C<sv_setsv>, but also handles 'set' magic.
2921 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2923 sv_setsv(dstr,sstr);
2928 =for apidoc sv_setpvn
2930 Copies a string into an SV. The C<len> parameter indicates the number of
2931 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2937 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2939 register char *dptr;
2941 /* len is STRLEN which is unsigned, need to copy to signed */
2945 SV_CHECK_THINKFIRST(sv);
2950 (void)SvUPGRADE(sv, SVt_PV);
2952 SvGROW(sv, len + 1);
2954 Move(ptr,dptr,len,char);
2957 (void)SvPOK_only(sv); /* validate pointer */
2962 =for apidoc sv_setpvn_mg
2964 Like C<sv_setpvn>, but also handles 'set' magic.
2970 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2972 sv_setpvn(sv,ptr,len);
2977 =for apidoc sv_setpv
2979 Copies a string into an SV. The string must be null-terminated. Does not
2980 handle 'set' magic. See C<sv_setpv_mg>.
2986 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2988 register STRLEN len;
2990 SV_CHECK_THINKFIRST(sv);
2996 (void)SvUPGRADE(sv, SVt_PV);
2998 SvGROW(sv, len + 1);
2999 Move(ptr,SvPVX(sv),len+1,char);
3001 (void)SvPOK_only(sv); /* validate pointer */
3006 =for apidoc sv_setpv_mg
3008 Like C<sv_setpv>, but also handles 'set' magic.
3014 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3021 =for apidoc sv_usepvn
3023 Tells an SV to use C<ptr> to find its string value. Normally the string is
3024 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3025 The C<ptr> should point to memory that was allocated by C<malloc>. The
3026 string length, C<len>, must be supplied. This function will realloc the
3027 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3028 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3029 See C<sv_usepvn_mg>.
3035 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3037 SV_CHECK_THINKFIRST(sv);
3038 (void)SvUPGRADE(sv, SVt_PV);
3043 (void)SvOOK_off(sv);
3044 if (SvPVX(sv) && SvLEN(sv))
3045 Safefree(SvPVX(sv));
3046 Renew(ptr, len+1, char);
3049 SvLEN_set(sv, len+1);
3051 (void)SvPOK_only(sv); /* validate pointer */
3056 =for apidoc sv_usepvn_mg
3058 Like C<sv_usepvn>, but also handles 'set' magic.
3064 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3066 sv_usepvn(sv,ptr,len);
3071 Perl_sv_force_normal(pTHX_ register SV *sv)
3073 if (SvREADONLY(sv)) {
3075 char *pvx = SvPVX(sv);
3076 STRLEN len = SvCUR(sv);
3077 U32 hash = SvUVX(sv);
3078 SvGROW(sv, len + 1);
3079 Move(pvx,SvPVX(sv),len,char);
3083 unsharepvn(pvx,len,hash);
3085 else if (PL_curcop != &PL_compiling)
3086 Perl_croak(aTHX_ PL_no_modify);
3090 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3097 Efficient removal of characters from the beginning of the string buffer.
3098 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3099 the string buffer. The C<ptr> becomes the first character of the adjusted
3106 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3110 register STRLEN delta;
3112 if (!ptr || !SvPOKp(sv))
3114 SV_CHECK_THINKFIRST(sv);
3115 if (SvTYPE(sv) < SVt_PVIV)
3116 sv_upgrade(sv,SVt_PVIV);
3119 if (!SvLEN(sv)) { /* make copy of shared string */
3120 char *pvx = SvPVX(sv);
3121 STRLEN len = SvCUR(sv);
3122 SvGROW(sv, len + 1);
3123 Move(pvx,SvPVX(sv),len,char);
3127 SvFLAGS(sv) |= SVf_OOK;
3129 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3130 delta = ptr - SvPVX(sv);
3138 =for apidoc sv_catpvn
3140 Concatenates the string onto the end of the string which is in the SV. The
3141 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3142 'set' magic. See C<sv_catpvn_mg>.
3148 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3153 junk = SvPV_force(sv, tlen);
3154 SvGROW(sv, tlen + len + 1);
3157 Move(ptr,SvPVX(sv)+tlen,len,char);
3160 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3165 =for apidoc sv_catpvn_mg
3167 Like C<sv_catpvn>, but also handles 'set' magic.
3173 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3175 sv_catpvn(sv,ptr,len);
3180 =for apidoc sv_catsv
3182 Concatenates the string from SV C<ssv> onto the end of the string in SV
3183 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3189 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3195 if ((s = SvPV(sstr, len))) {
3196 if (DO_UTF8(sstr)) {
3197 sv_utf8_upgrade(dstr);
3198 sv_catpvn(dstr,s,len);
3202 sv_catpvn(dstr,s,len);
3207 =for apidoc sv_catsv_mg
3209 Like C<sv_catsv>, but also handles 'set' magic.
3215 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3217 sv_catsv(dstr,sstr);
3222 =for apidoc sv_catpv
3224 Concatenates the string onto the end of the string which is in the SV.
3225 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3231 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3233 register STRLEN len;
3239 junk = SvPV_force(sv, tlen);
3241 SvGROW(sv, tlen + len + 1);
3244 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3246 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3251 =for apidoc sv_catpv_mg
3253 Like C<sv_catpv>, but also handles 'set' magic.
3259 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3266 Perl_newSV(pTHX_ STRLEN len)
3272 sv_upgrade(sv, SVt_PV);
3273 SvGROW(sv, len + 1);
3278 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3281 =for apidoc sv_magic
3283 Adds magic to an SV.
3289 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3293 if (SvREADONLY(sv)) {
3294 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3295 Perl_croak(aTHX_ PL_no_modify);
3297 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3298 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3305 (void)SvUPGRADE(sv, SVt_PVMG);
3307 Newz(702,mg, 1, MAGIC);
3308 mg->mg_moremagic = SvMAGIC(sv);
3311 if (!obj || obj == sv || how == '#' || how == 'r')
3314 mg->mg_obj = SvREFCNT_inc(obj);
3315 mg->mg_flags |= MGf_REFCOUNTED;
3318 mg->mg_len = namlen;
3321 mg->mg_ptr = savepvn(name, namlen);
3322 else if (namlen == HEf_SVKEY)
3323 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3327 mg->mg_virtual = &PL_vtbl_sv;
3330 mg->mg_virtual = &PL_vtbl_amagic;
3333 mg->mg_virtual = &PL_vtbl_amagicelem;
3339 mg->mg_virtual = &PL_vtbl_bm;
3342 mg->mg_virtual = &PL_vtbl_regdata;
3345 mg->mg_virtual = &PL_vtbl_regdatum;
3348 mg->mg_virtual = &PL_vtbl_env;
3351 mg->mg_virtual = &PL_vtbl_fm;
3354 mg->mg_virtual = &PL_vtbl_envelem;
3357 mg->mg_virtual = &PL_vtbl_mglob;
3360 mg->mg_virtual = &PL_vtbl_isa;
3363 mg->mg_virtual = &PL_vtbl_isaelem;
3366 mg->mg_virtual = &PL_vtbl_nkeys;
3373 mg->mg_virtual = &PL_vtbl_dbline;
3377 mg->mg_virtual = &PL_vtbl_mutex;
3379 #endif /* USE_THREADS */
3380 #ifdef USE_LOCALE_COLLATE
3382 mg->mg_virtual = &PL_vtbl_collxfrm;
3384 #endif /* USE_LOCALE_COLLATE */
3386 mg->mg_virtual = &PL_vtbl_pack;
3390 mg->mg_virtual = &PL_vtbl_packelem;
3393 mg->mg_virtual = &PL_vtbl_regexp;
3396 mg->mg_virtual = &PL_vtbl_sig;
3399 mg->mg_virtual = &PL_vtbl_sigelem;
3402 mg->mg_virtual = &PL_vtbl_taint;
3406 mg->mg_virtual = &PL_vtbl_uvar;
3409 mg->mg_virtual = &PL_vtbl_vec;
3412 mg->mg_virtual = &PL_vtbl_substr;
3415 mg->mg_virtual = &PL_vtbl_defelem;
3418 mg->mg_virtual = &PL_vtbl_glob;
3421 mg->mg_virtual = &PL_vtbl_arylen;
3424 mg->mg_virtual = &PL_vtbl_pos;
3427 mg->mg_virtual = &PL_vtbl_backref;
3429 case '~': /* Reserved for use by extensions not perl internals. */
3430 /* Useful for attaching extension internal data to perl vars. */
3431 /* Note that multiple extensions may clash if magical scalars */
3432 /* etc holding private data from one are passed to another. */
3436 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3440 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3444 =for apidoc sv_unmagic
3446 Removes magic from an SV.
3452 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3456 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3459 for (mg = *mgp; mg; mg = *mgp) {
3460 if (mg->mg_type == type) {
3461 MGVTBL* vtbl = mg->mg_virtual;
3462 *mgp = mg->mg_moremagic;
3463 if (vtbl && vtbl->svt_free)
3464 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3465 if (mg->mg_ptr && mg->mg_type != 'g')
3466 if (mg->mg_len >= 0)
3467 Safefree(mg->mg_ptr);
3468 else if (mg->mg_len == HEf_SVKEY)
3469 SvREFCNT_dec((SV*)mg->mg_ptr);
3470 if (mg->mg_flags & MGf_REFCOUNTED)
3471 SvREFCNT_dec(mg->mg_obj);
3475 mgp = &mg->mg_moremagic;
3479 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3486 =for apidoc sv_rvweaken
3494 Perl_sv_rvweaken(pTHX_ SV *sv)
3497 if (!SvOK(sv)) /* let undefs pass */
3500 Perl_croak(aTHX_ "Can't weaken a nonreference");
3501 else if (SvWEAKREF(sv)) {
3502 if (ckWARN(WARN_MISC))
3503 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3507 sv_add_backref(tsv, sv);
3514 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3518 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3519 av = (AV*)mg->mg_obj;
3522 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3523 SvREFCNT_dec(av); /* for sv_magic */
3529 S_sv_del_backref(pTHX_ SV *sv)
3536 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3537 Perl_croak(aTHX_ "panic: del_backref");
3538 av = (AV *)mg->mg_obj;
3543 svp[i] = &PL_sv_undef; /* XXX */
3550 =for apidoc sv_insert
3552 Inserts a string at the specified offset/length within the SV. Similar to
3553 the Perl substr() function.
3559 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3563 register char *midend;
3564 register char *bigend;
3570 Perl_croak(aTHX_ "Can't modify non-existent substring");
3571 SvPV_force(bigstr, curlen);
3572 (void)SvPOK_only_UTF8(bigstr);
3573 if (offset + len > curlen) {
3574 SvGROW(bigstr, offset+len+1);
3575 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3576 SvCUR_set(bigstr, offset+len);
3580 i = littlelen - len;
3581 if (i > 0) { /* string might grow */
3582 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3583 mid = big + offset + len;
3584 midend = bigend = big + SvCUR(bigstr);
3587 while (midend > mid) /* shove everything down */
3588 *--bigend = *--midend;
3589 Move(little,big+offset,littlelen,char);
3595 Move(little,SvPVX(bigstr)+offset,len,char);
3600 big = SvPVX(bigstr);
3603 bigend = big + SvCUR(bigstr);
3605 if (midend > bigend)
3606 Perl_croak(aTHX_ "panic: sv_insert");
3608 if (mid - big > bigend - midend) { /* faster to shorten from end */
3610 Move(little, mid, littlelen,char);
3613 i = bigend - midend;
3615 Move(midend, mid, i,char);
3619 SvCUR_set(bigstr, mid - big);
3622 else if ((i = mid - big)) { /* faster from front */
3623 midend -= littlelen;
3625 sv_chop(bigstr,midend-i);
3630 Move(little, mid, littlelen,char);
3632 else if (littlelen) {
3633 midend -= littlelen;
3634 sv_chop(bigstr,midend);
3635 Move(little,midend,littlelen,char);
3638 sv_chop(bigstr,midend);
3644 =for apidoc sv_replace
3646 Make the first argument a copy of the second, then delete the original.
3652 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3654 U32 refcnt = SvREFCNT(sv);
3655 SV_CHECK_THINKFIRST(sv);
3656 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3657 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3658 if (SvMAGICAL(sv)) {
3662 sv_upgrade(nsv, SVt_PVMG);
3663 SvMAGIC(nsv) = SvMAGIC(sv);
3664 SvFLAGS(nsv) |= SvMAGICAL(sv);
3670 assert(!SvREFCNT(sv));
3671 StructCopy(nsv,sv,SV);
3672 SvREFCNT(sv) = refcnt;
3673 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3678 =for apidoc sv_clear
3680 Clear an SV, making it empty. Does not free the memory used by the SV
3687 Perl_sv_clear(pTHX_ register SV *sv)
3691 assert(SvREFCNT(sv) == 0);
3694 if (PL_defstash) { /* Still have a symbol table? */
3699 Zero(&tmpref, 1, SV);
3700 sv_upgrade(&tmpref, SVt_RV);
3702 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3703 SvREFCNT(&tmpref) = 1;
3706 stash = SvSTASH(sv);
3707 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3710 PUSHSTACKi(PERLSI_DESTROY);
3711 SvRV(&tmpref) = SvREFCNT_inc(sv);
3716 call_sv((SV*)GvCV(destructor),
3717 G_DISCARD|G_EVAL|G_KEEPERR);
3723 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3725 del_XRV(SvANY(&tmpref));
3728 if (PL_in_clean_objs)
3729 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3731 /* DESTROY gave object new lease on life */
3737 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3738 SvOBJECT_off(sv); /* Curse the object. */
3739 if (SvTYPE(sv) != SVt_PVIO)
3740 --PL_sv_objcount; /* XXX Might want something more general */
3743 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3746 switch (SvTYPE(sv)) {
3749 IoIFP(sv) != PerlIO_stdin() &&
3750 IoIFP(sv) != PerlIO_stdout() &&
3751 IoIFP(sv) != PerlIO_stderr())
3753 io_close((IO*)sv, FALSE);
3755 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3756 PerlDir_close(IoDIRP(sv));
3757 IoDIRP(sv) = (DIR*)NULL;
3758 Safefree(IoTOP_NAME(sv));
3759 Safefree(IoFMT_NAME(sv));
3760 Safefree(IoBOTTOM_NAME(sv));
3775 SvREFCNT_dec(LvTARG(sv));
3779 Safefree(GvNAME(sv));
3780 /* cannot decrease stash refcount yet, as we might recursively delete
3781 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3782 of stash until current sv is completely gone.
3783 -- JohnPC, 27 Mar 1998 */
3784 stash = GvSTASH(sv);
3790 (void)SvOOK_off(sv);
3798 SvREFCNT_dec(SvRV(sv));
3800 else if (SvPVX(sv) && SvLEN(sv))
3801 Safefree(SvPVX(sv));
3802 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
3803 unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv));
3815 switch (SvTYPE(sv)) {
3831 del_XPVIV(SvANY(sv));
3834 del_XPVNV(SvANY(sv));
3837 del_XPVMG(SvANY(sv));
3840 del_XPVLV(SvANY(sv));
3843 del_XPVAV(SvANY(sv));
3846 del_XPVHV(SvANY(sv));
3849 del_XPVCV(SvANY(sv));
3852 del_XPVGV(SvANY(sv));
3853 /* code duplication for increased performance. */
3854 SvFLAGS(sv) &= SVf_BREAK;
3855 SvFLAGS(sv) |= SVTYPEMASK;
3856 /* decrease refcount of the stash that owns this GV, if any */
3858 SvREFCNT_dec(stash);
3859 return; /* not break, SvFLAGS reset already happened */
3861 del_XPVBM(SvANY(sv));
3864 del_XPVFM(SvANY(sv));
3867 del_XPVIO(SvANY(sv));
3870 SvFLAGS(sv) &= SVf_BREAK;
3871 SvFLAGS(sv) |= SVTYPEMASK;
3875 Perl_sv_newref(pTHX_ SV *sv)
3878 ATOMIC_INC(SvREFCNT(sv));
3885 Free the memory used by an SV.
3891 Perl_sv_free(pTHX_ SV *sv)
3893 int refcount_is_zero;
3897 if (SvREFCNT(sv) == 0) {
3898 if (SvFLAGS(sv) & SVf_BREAK)
3900 if (PL_in_clean_all) /* All is fair */
3902 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3903 /* make sure SvREFCNT(sv)==0 happens very seldom */
3904 SvREFCNT(sv) = (~(U32)0)/2;
3907 if (ckWARN_d(WARN_INTERNAL))
3908 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3911 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3912 if (!refcount_is_zero)
3916 if (ckWARN_d(WARN_DEBUGGING))
3917 Perl_warner(aTHX_ WARN_DEBUGGING,
3918 "Attempt to free temp prematurely: SV 0x%"UVxf,
3923 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3924 /* make sure SvREFCNT(sv)==0 happens very seldom */
3925 SvREFCNT(sv) = (~(U32)0)/2;
3936 Returns the length of the string in the SV. See also C<SvCUR>.
3942 Perl_sv_len(pTHX_ register SV *sv)
3951 len = mg_length(sv);
3953 junk = SvPV(sv, len);
3958 =for apidoc sv_len_utf8
3960 Returns the number of characters in the string in an SV, counting wide
3961 UTF8 bytes as a single character.
3967 Perl_sv_len_utf8(pTHX_ register SV *sv)
3974 return mg_length(sv);
3979 U8 *s = (U8*)SvPV(sv, len);
3981 return Perl_utf8_length(aTHX_ s, s + len);
3986 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3991 I32 uoffset = *offsetp;
3997 start = s = (U8*)SvPV(sv, len);
3999 while (s < send && uoffset--)
4003 *offsetp = s - start;
4007 while (s < send && ulen--)
4017 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4026 s = (U8*)SvPV(sv, len);
4028 Perl_croak(aTHX_ "panic: bad byte offset");
4029 send = s + *offsetp;
4036 if (ckWARN_d(WARN_UTF8))
4037 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4047 Returns a boolean indicating whether the strings in the two SVs are
4054 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4061 bool pv1tmp = FALSE;
4062 bool pv2tmp = FALSE;
4069 pv1 = SvPV(sv1, cur1);
4076 pv2 = SvPV(sv2, cur2);
4078 /* do not utf8ize the comparands as a side-effect */
4079 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4081 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4085 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4091 eq = memEQ(pv1, pv2, cur1);
4104 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4105 string in C<sv1> is less than, equal to, or greater than the string in
4112 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4117 bool pv1tmp = FALSE;
4118 bool pv2tmp = FALSE;
4125 pv1 = SvPV(sv1, cur1);
4132 pv2 = SvPV(sv2, cur2);
4134 /* do not utf8ize the comparands as a side-effect */
4135 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4137 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4141 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4147 cmp = cur2 ? -1 : 0;
4151 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4154 cmp = retval < 0 ? -1 : 1;
4155 } else if (cur1 == cur2) {
4158 cmp = cur1 < cur2 ? -1 : 1;
4171 =for apidoc sv_cmp_locale
4173 Compares the strings in two SVs in a locale-aware manner. See
4180 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4182 #ifdef USE_LOCALE_COLLATE
4188 if (PL_collation_standard)
4192 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4194 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4196 if (!pv1 || !len1) {
4207 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4210 return retval < 0 ? -1 : 1;
4213 * When the result of collation is equality, that doesn't mean
4214 * that there are no differences -- some locales exclude some
4215 * characters from consideration. So to avoid false equalities,
4216 * we use the raw string as a tiebreaker.
4222 #endif /* USE_LOCALE_COLLATE */
4224 return sv_cmp(sv1, sv2);
4227 #ifdef USE_LOCALE_COLLATE
4229 * Any scalar variable may carry an 'o' magic that contains the
4230 * scalar data of the variable transformed to such a format that
4231 * a normal memory comparison can be used to compare the data
4232 * according to the locale settings.
4235 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4239 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4240 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4245 Safefree(mg->mg_ptr);
4247 if ((xf = mem_collxfrm(s, len, &xlen))) {
4248 if (SvREADONLY(sv)) {
4251 return xf + sizeof(PL_collation_ix);
4254 sv_magic(sv, 0, 'o', 0, 0);
4255 mg = mg_find(sv, 'o');
4268 if (mg && mg->mg_ptr) {
4270 return mg->mg_ptr + sizeof(PL_collation_ix);
4278 #endif /* USE_LOCALE_COLLATE */
4283 Get a line from the filehandle and store it into the SV, optionally
4284 appending to the currently-stored string.
4290 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4294 register STDCHAR rslast;
4295 register STDCHAR *bp;
4299 SV_CHECK_THINKFIRST(sv);
4300 (void)SvUPGRADE(sv, SVt_PV);
4304 if (RsSNARF(PL_rs)) {
4308 else if (RsRECORD(PL_rs)) {
4309 I32 recsize, bytesread;
4312 /* Grab the size of the record we're getting */
4313 recsize = SvIV(SvRV(PL_rs));
4314 (void)SvPOK_only(sv); /* Validate pointer */
4315 buffer = SvGROW(sv, recsize + 1);
4318 /* VMS wants read instead of fread, because fread doesn't respect */
4319 /* RMS record boundaries. This is not necessarily a good thing to be */
4320 /* doing, but we've got no other real choice */
4321 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4323 bytesread = PerlIO_read(fp, buffer, recsize);
4325 SvCUR_set(sv, bytesread);
4326 buffer[bytesread] = '\0';
4327 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4329 else if (RsPARA(PL_rs)) {
4334 rsptr = SvPV(PL_rs, rslen);
4335 rslast = rslen ? rsptr[rslen - 1] : '\0';
4337 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4338 do { /* to make sure file boundaries work right */
4341 i = PerlIO_getc(fp);
4345 PerlIO_ungetc(fp,i);
4351 /* See if we know enough about I/O mechanism to cheat it ! */
4353 /* This used to be #ifdef test - it is made run-time test for ease
4354 of abstracting out stdio interface. One call should be cheap
4355 enough here - and may even be a macro allowing compile
4359 if (PerlIO_fast_gets(fp)) {
4362 * We're going to steal some values from the stdio struct
4363 * and put EVERYTHING in the innermost loop into registers.
4365 register STDCHAR *ptr;
4369 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4370 /* An ungetc()d char is handled separately from the regular
4371 * buffer, so we getc() it back out and stuff it in the buffer.
4373 i = PerlIO_getc(fp);
4374 if (i == EOF) return 0;
4375 *(--((*fp)->_ptr)) = (unsigned char) i;
4379 /* Here is some breathtakingly efficient cheating */
4381 cnt = PerlIO_get_cnt(fp); /* get count into register */
4382 (void)SvPOK_only(sv); /* validate pointer */
4383 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4384 if (cnt > 80 && SvLEN(sv) > append) {
4385 shortbuffered = cnt - SvLEN(sv) + append + 1;
4386 cnt -= shortbuffered;
4390 /* remember that cnt can be negative */
4391 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4396 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4397 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4398 DEBUG_P(PerlIO_printf(Perl_debug_log,
4399 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4400 DEBUG_P(PerlIO_printf(Perl_debug_log,
4401 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4402 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4403 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4408 while (cnt > 0) { /* this | eat */
4410 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4411 goto thats_all_folks; /* screams | sed :-) */
4415 Copy(ptr, bp, cnt, char); /* this | eat */
4416 bp += cnt; /* screams | dust */
4417 ptr += cnt; /* louder | sed :-) */
4422 if (shortbuffered) { /* oh well, must extend */
4423 cnt = shortbuffered;
4425 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4427 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4428 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4432 DEBUG_P(PerlIO_printf(Perl_debug_log,
4433 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4434 PTR2UV(ptr),(long)cnt));
4435 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4436 DEBUG_P(PerlIO_printf(Perl_debug_log,
4437 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4438 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4439 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4440 /* This used to call 'filbuf' in stdio form, but as that behaves like
4441 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4442 another abstraction. */
4443 i = PerlIO_getc(fp); /* get more characters */
4444 DEBUG_P(PerlIO_printf(Perl_debug_log,
4445 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4446 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4447 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4448 cnt = PerlIO_get_cnt(fp);
4449 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4450 DEBUG_P(PerlIO_printf(Perl_debug_log,
4451 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4453 if (i == EOF) /* all done for ever? */
4454 goto thats_really_all_folks;
4456 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4458 SvGROW(sv, bpx + cnt + 2);
4459 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4461 *bp++ = i; /* store character from PerlIO_getc */
4463 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4464 goto thats_all_folks;
4468 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4469 memNE((char*)bp - rslen, rsptr, rslen))
4470 goto screamer; /* go back to the fray */
4471 thats_really_all_folks:
4473 cnt += shortbuffered;
4474 DEBUG_P(PerlIO_printf(Perl_debug_log,
4475 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4476 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4477 DEBUG_P(PerlIO_printf(Perl_debug_log,
4478 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4479 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4480 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4482 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4483 DEBUG_P(PerlIO_printf(Perl_debug_log,
4484 "Screamer: done, len=%ld, string=|%.*s|\n",
4485 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4490 /*The big, slow, and stupid way */
4493 /* Need to work around EPOC SDK features */
4494 /* On WINS: MS VC5 generates calls to _chkstk, */
4495 /* if a `large' stack frame is allocated */
4496 /* gcc on MARM does not generate calls like these */
4502 register STDCHAR *bpe = buf + sizeof(buf);
4504 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4505 ; /* keep reading */
4509 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4510 /* Accomodate broken VAXC compiler, which applies U8 cast to
4511 * both args of ?: operator, causing EOF to change into 255
4513 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4517 sv_catpvn(sv, (char *) buf, cnt);
4519 sv_setpvn(sv, (char *) buf, cnt);
4521 if (i != EOF && /* joy */
4523 SvCUR(sv) < rslen ||
4524 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4528 * If we're reading from a TTY and we get a short read,
4529 * indicating that the user hit his EOF character, we need
4530 * to notice it now, because if we try to read from the TTY
4531 * again, the EOF condition will disappear.
4533 * The comparison of cnt to sizeof(buf) is an optimization
4534 * that prevents unnecessary calls to feof().
4538 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4543 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4544 while (i != EOF) { /* to make sure file boundaries work right */
4545 i = PerlIO_getc(fp);
4547 PerlIO_ungetc(fp,i);
4553 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4560 Auto-increment of the value in the SV.
4566 Perl_sv_inc(pTHX_ register SV *sv)
4575 if (SvTHINKFIRST(sv)) {
4576 if (SvREADONLY(sv)) {
4577 if (PL_curcop != &PL_compiling)
4578 Perl_croak(aTHX_ PL_no_modify);
4582 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4584 i = PTR2IV(SvRV(sv));
4589 flags = SvFLAGS(sv);
4590 if (flags & SVp_NOK) {
4591 (void)SvNOK_only(sv);
4595 if (flags & SVp_IOK) {
4597 if (SvUVX(sv) == UV_MAX)
4598 sv_setnv(sv, (NV)UV_MAX + 1.0);
4600 (void)SvIOK_only_UV(sv);
4603 if (SvIVX(sv) == IV_MAX)
4604 sv_setnv(sv, (NV)IV_MAX + 1.0);
4606 (void)SvIOK_only(sv);
4612 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4613 if ((flags & SVTYPEMASK) < SVt_PVNV)
4614 sv_upgrade(sv, SVt_IV);
4615 (void)SvIOK_only(sv);
4620 while (isALPHA(*d)) d++;
4621 while (isDIGIT(*d)) d++;
4623 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4627 while (d >= SvPVX(sv)) {
4635 /* MKS: The original code here died if letters weren't consecutive.
4636 * at least it didn't have to worry about non-C locales. The
4637 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4638 * arranged in order (although not consecutively) and that only
4639 * [A-Za-z] are accepted by isALPHA in the C locale.
4641 if (*d != 'z' && *d != 'Z') {
4642 do { ++*d; } while (!isALPHA(*d));
4645 *(d--) -= 'z' - 'a';
4650 *(d--) -= 'z' - 'a' + 1;
4654 /* oh,oh, the number grew */
4655 SvGROW(sv, SvCUR(sv) + 2);
4657 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4668 Auto-decrement of the value in the SV.
4674 Perl_sv_dec(pTHX_ register SV *sv)
4682 if (SvTHINKFIRST(sv)) {
4683 if (SvREADONLY(sv)) {
4684 if (PL_curcop != &PL_compiling)
4685 Perl_croak(aTHX_ PL_no_modify);
4689 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4691 i = PTR2IV(SvRV(sv));
4696 flags = SvFLAGS(sv);
4697 if (flags & SVp_NOK) {
4699 (void)SvNOK_only(sv);
4702 if (flags & SVp_IOK) {
4704 if (SvUVX(sv) == 0) {
4705 (void)SvIOK_only(sv);
4709 (void)SvIOK_only_UV(sv);
4713 if (SvIVX(sv) == IV_MIN)
4714 sv_setnv(sv, (NV)IV_MIN - 1.0);
4716 (void)SvIOK_only(sv);
4722 if (!(flags & SVp_POK)) {
4723 if ((flags & SVTYPEMASK) < SVt_PVNV)
4724 sv_upgrade(sv, SVt_NV);
4726 (void)SvNOK_only(sv);
4729 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4733 =for apidoc sv_mortalcopy
4735 Creates a new SV which is a copy of the original SV. The new SV is marked
4741 /* Make a string that will exist for the duration of the expression
4742 * evaluation. Actually, it may have to last longer than that, but
4743 * hopefully we won't free it until it has been assigned to a
4744 * permanent location. */
4747 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4752 sv_setsv(sv,oldstr);
4754 PL_tmps_stack[++PL_tmps_ix] = sv;
4760 =for apidoc sv_newmortal
4762 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4768 Perl_sv_newmortal(pTHX)
4773 SvFLAGS(sv) = SVs_TEMP;
4775 PL_tmps_stack[++PL_tmps_ix] = sv;
4780 =for apidoc sv_2mortal
4782 Marks an SV as mortal. The SV will be destroyed when the current context
4788 /* same thing without the copying */
4791 Perl_sv_2mortal(pTHX_ register SV *sv)
4795 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4798 PL_tmps_stack[++PL_tmps_ix] = sv;
4806 Creates a new SV and copies a string into it. The reference count for the
4807 SV is set to 1. If C<len> is zero, Perl will compute the length using
4808 strlen(). For efficiency, consider using C<newSVpvn> instead.
4814 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4821 sv_setpvn(sv,s,len);
4826 =for apidoc newSVpvn
4828 Creates a new SV and copies a string into it. The reference count for the
4829 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4830 string. You are responsible for ensuring that the source string is at least
4837 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4842 sv_setpvn(sv,s,len);
4847 =for apidoc newSVpvn_share
4849 Creates a new SV and populates it with a string from
4850 the string table. Turns on READONLY and FAKE.
4851 The idea here is that as string table is used for shared hash
4852 keys these strings will have SvPVX == HeKEY and hash lookup
4853 will avoid string compare.
4859 Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash)
4863 PERL_HASH(hash, src, len);
4865 sv_upgrade(sv, SVt_PVIV);
4866 SvPVX(sv) = sharepvn(src, len, hash);
4876 #if defined(PERL_IMPLICIT_CONTEXT)
4878 Perl_newSVpvf_nocontext(const char* pat, ...)
4883 va_start(args, pat);
4884 sv = vnewSVpvf(pat, &args);
4891 =for apidoc newSVpvf
4893 Creates a new SV an initialize it with the string formatted like
4900 Perl_newSVpvf(pTHX_ const char* pat, ...)
4904 va_start(args, pat);
4905 sv = vnewSVpvf(pat, &args);
4911 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4915 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4922 Creates a new SV and copies a floating point value into it.
4923 The reference count for the SV is set to 1.
4929 Perl_newSVnv(pTHX_ NV n)
4941 Creates a new SV and copies an integer into it. The reference count for the
4948 Perl_newSViv(pTHX_ IV i)
4960 Creates a new SV and copies an unsigned integer into it.
4961 The reference count for the SV is set to 1.
4967 Perl_newSVuv(pTHX_ UV u)
4977 =for apidoc newRV_noinc
4979 Creates an RV wrapper for an SV. The reference count for the original
4980 SV is B<not> incremented.
4986 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4991 sv_upgrade(sv, SVt_RV);
4998 /* newRV_inc is #defined to newRV in sv.h */
5000 Perl_newRV(pTHX_ SV *tmpRef)
5002 return newRV_noinc(SvREFCNT_inc(tmpRef));
5008 Creates a new SV which is an exact duplicate of the original SV.
5013 /* make an exact duplicate of old */
5016 Perl_newSVsv(pTHX_ register SV *old)
5022 if (SvTYPE(old) == SVTYPEMASK) {
5023 if (ckWARN_d(WARN_INTERNAL))
5024 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5039 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5047 char todo[PERL_UCHAR_MAX+1];
5052 if (!*s) { /* reset ?? searches */
5053 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5054 pm->op_pmdynflags &= ~PMdf_USED;
5059 /* reset variables */
5061 if (!HvARRAY(stash))
5064 Zero(todo, 256, char);
5066 i = (unsigned char)*s;
5070 max = (unsigned char)*s++;
5071 for ( ; i <= max; i++) {
5074 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5075 for (entry = HvARRAY(stash)[i];
5077 entry = HeNEXT(entry))
5079 if (!todo[(U8)*HeKEY(entry)])
5081 gv = (GV*)HeVAL(entry);
5083 if (SvTHINKFIRST(sv)) {
5084 if (!SvREADONLY(sv) && SvROK(sv))
5089 if (SvTYPE(sv) >= SVt_PV) {
5091 if (SvPVX(sv) != Nullch)
5098 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5100 #ifdef USE_ENVIRON_ARRAY
5102 environ[0] = Nullch;
5111 Perl_sv_2io(pTHX_ SV *sv)
5117 switch (SvTYPE(sv)) {
5125 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5129 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5131 return sv_2io(SvRV(sv));
5132 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5138 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5145 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5152 return *gvp = Nullgv, Nullcv;
5153 switch (SvTYPE(sv)) {
5172 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5173 tryAMAGICunDEREF(to_cv);
5176 if (SvTYPE(sv) == SVt_PVCV) {
5185 Perl_croak(aTHX_ "Not a subroutine reference");
5190 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5196 if (lref && !GvCVu(gv)) {
5199 tmpsv = NEWSV(704,0);
5200 gv_efullname3(tmpsv, gv, Nullch);
5201 /* XXX this is probably not what they think they're getting.
5202 * It has the same effect as "sub name;", i.e. just a forward
5204 newSUB(start_subparse(FALSE, 0),
5205 newSVOP(OP_CONST, 0, tmpsv),
5210 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5219 Returns true if the SV has a true value by Perl's rules.
5225 Perl_sv_true(pTHX_ register SV *sv)
5231 if ((tXpv = (XPV*)SvANY(sv)) &&
5232 (tXpv->xpv_cur > 1 ||
5233 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5240 return SvIVX(sv) != 0;
5243 return SvNVX(sv) != 0.0;
5245 return sv_2bool(sv);
5251 Perl_sv_iv(pTHX_ register SV *sv)
5255 return (IV)SvUVX(sv);
5262 Perl_sv_uv(pTHX_ register SV *sv)
5267 return (UV)SvIVX(sv);
5273 Perl_sv_nv(pTHX_ register SV *sv)
5281 Perl_sv_pv(pTHX_ SV *sv)
5288 return sv_2pv(sv, &n_a);
5292 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5298 return sv_2pv(sv, lp);
5302 =for apidoc sv_pvn_force
5304 Get a sensible string out of the SV somehow.
5310 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5314 if (SvTHINKFIRST(sv) && !SvROK(sv))
5315 sv_force_normal(sv);
5321 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5322 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5323 PL_op_name[PL_op->op_type]);
5327 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5332 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5333 SvGROW(sv, len + 1);
5334 Move(s,SvPVX(sv),len,char);
5339 SvPOK_on(sv); /* validate pointer */
5341 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5342 PTR2UV(sv),SvPVX(sv)));
5349 Perl_sv_pvbyte(pTHX_ SV *sv)
5355 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5357 return sv_pvn(sv,lp);
5361 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5363 return sv_pvn_force(sv,lp);
5367 Perl_sv_pvutf8(pTHX_ SV *sv)
5369 sv_utf8_upgrade(sv);
5374 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5376 sv_utf8_upgrade(sv);
5377 return sv_pvn(sv,lp);
5381 =for apidoc sv_pvutf8n_force
5383 Get a sensible UTF8-encoded string out of the SV somehow. See
5390 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5392 sv_utf8_upgrade(sv);
5393 return sv_pvn_force(sv,lp);
5397 =for apidoc sv_reftype
5399 Returns a string describing what the SV is a reference to.
5405 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5407 if (ob && SvOBJECT(sv))
5408 return HvNAME(SvSTASH(sv));
5410 switch (SvTYPE(sv)) {
5424 case SVt_PVLV: return "LVALUE";
5425 case SVt_PVAV: return "ARRAY";
5426 case SVt_PVHV: return "HASH";
5427 case SVt_PVCV: return "CODE";
5428 case SVt_PVGV: return "GLOB";
5429 case SVt_PVFM: return "FORMAT";
5430 case SVt_PVIO: return "IO";
5431 default: return "UNKNOWN";
5437 =for apidoc sv_isobject
5439 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5440 object. If the SV is not an RV, or if the object is not blessed, then this
5447 Perl_sv_isobject(pTHX_ SV *sv)
5464 Returns a boolean indicating whether the SV is blessed into the specified
5465 class. This does not check for subtypes; use C<sv_derived_from> to verify
5466 an inheritance relationship.
5472 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5484 return strEQ(HvNAME(SvSTASH(sv)), name);
5490 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5491 it will be upgraded to one. If C<classname> is non-null then the new SV will
5492 be blessed in the specified package. The new SV is returned and its
5493 reference count is 1.
5499 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5505 SV_CHECK_THINKFIRST(rv);
5508 if (SvTYPE(rv) >= SVt_PVMG) {
5509 U32 refcnt = SvREFCNT(rv);
5513 SvREFCNT(rv) = refcnt;
5516 if (SvTYPE(rv) < SVt_RV)
5517 sv_upgrade(rv, SVt_RV);
5518 else if (SvTYPE(rv) > SVt_RV) {
5519 (void)SvOOK_off(rv);
5520 if (SvPVX(rv) && SvLEN(rv))
5521 Safefree(SvPVX(rv));
5531 HV* stash = gv_stashpv(classname, TRUE);
5532 (void)sv_bless(rv, stash);
5538 =for apidoc sv_setref_pv
5540 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5541 argument will be upgraded to an RV. That RV will be modified to point to
5542 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5543 into the SV. The C<classname> argument indicates the package for the
5544 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5545 will be returned and will have a reference count of 1.
5547 Do not use with other Perl types such as HV, AV, SV, CV, because those
5548 objects will become corrupted by the pointer copy process.
5550 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5556 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5559 sv_setsv(rv, &PL_sv_undef);
5563 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5568 =for apidoc sv_setref_iv
5570 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5571 argument will be upgraded to an RV. That RV will be modified to point to
5572 the new SV. The C<classname> argument indicates the package for the
5573 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5574 will be returned and will have a reference count of 1.
5580 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5582 sv_setiv(newSVrv(rv,classname), iv);
5587 =for apidoc sv_setref_nv
5589 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5590 argument will be upgraded to an RV. That RV will be modified to point to
5591 the new SV. The C<classname> argument indicates the package for the
5592 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5593 will be returned and will have a reference count of 1.
5599 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5601 sv_setnv(newSVrv(rv,classname), nv);
5606 =for apidoc sv_setref_pvn
5608 Copies a string into a new SV, optionally blessing the SV. The length of the
5609 string must be specified with C<n>. The C<rv> argument will be upgraded to
5610 an RV. That RV will be modified to point to the new SV. The C<classname>
5611 argument indicates the package for the blessing. Set C<classname> to
5612 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5613 a reference count of 1.
5615 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5621 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5623 sv_setpvn(newSVrv(rv,classname), pv, n);
5628 =for apidoc sv_bless
5630 Blesses an SV into a specified package. The SV must be an RV. The package
5631 must be designated by its stash (see C<gv_stashpv()>). The reference count
5632 of the SV is unaffected.
5638 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5642 Perl_croak(aTHX_ "Can't bless non-reference value");
5644 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5645 if (SvREADONLY(tmpRef))
5646 Perl_croak(aTHX_ PL_no_modify);
5647 if (SvOBJECT(tmpRef)) {
5648 if (SvTYPE(tmpRef) != SVt_PVIO)
5650 SvREFCNT_dec(SvSTASH(tmpRef));
5653 SvOBJECT_on(tmpRef);
5654 if (SvTYPE(tmpRef) != SVt_PVIO)
5656 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5657 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5668 S_sv_unglob(pTHX_ SV *sv)
5672 assert(SvTYPE(sv) == SVt_PVGV);
5677 SvREFCNT_dec(GvSTASH(sv));
5678 GvSTASH(sv) = Nullhv;
5680 sv_unmagic(sv, '*');
5681 Safefree(GvNAME(sv));
5684 /* need to keep SvANY(sv) in the right arena */
5685 xpvmg = new_XPVMG();
5686 StructCopy(SvANY(sv), xpvmg, XPVMG);
5687 del_XPVGV(SvANY(sv));
5690 SvFLAGS(sv) &= ~SVTYPEMASK;
5691 SvFLAGS(sv) |= SVt_PVMG;
5695 =for apidoc sv_unref
5697 Unsets the RV status of the SV, and decrements the reference count of
5698 whatever was being referenced by the RV. This can almost be thought of
5699 as a reversal of C<newSVrv>. See C<SvROK_off>.
5705 Perl_sv_unref(pTHX_ SV *sv)
5709 if (SvWEAKREF(sv)) {
5717 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5720 sv_2mortal(rv); /* Schedule for freeing later */
5724 Perl_sv_taint(pTHX_ SV *sv)
5726 sv_magic((sv), Nullsv, 't', Nullch, 0);
5730 Perl_sv_untaint(pTHX_ SV *sv)
5732 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5733 MAGIC *mg = mg_find(sv, 't');
5740 Perl_sv_tainted(pTHX_ SV *sv)
5742 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5743 MAGIC *mg = mg_find(sv, 't');
5744 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5751 =for apidoc sv_setpviv
5753 Copies an integer into the given SV, also updating its string value.
5754 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5760 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5762 char buf[TYPE_CHARS(UV)];
5764 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5766 sv_setpvn(sv, ptr, ebuf - ptr);
5771 =for apidoc sv_setpviv_mg
5773 Like C<sv_setpviv>, but also handles 'set' magic.
5779 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5781 char buf[TYPE_CHARS(UV)];
5783 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5785 sv_setpvn(sv, ptr, ebuf - ptr);
5789 #if defined(PERL_IMPLICIT_CONTEXT)
5791 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5795 va_start(args, pat);
5796 sv_vsetpvf(sv, pat, &args);
5802 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5806 va_start(args, pat);
5807 sv_vsetpvf_mg(sv, pat, &args);
5813 =for apidoc sv_setpvf
5815 Processes its arguments like C<sprintf> and sets an SV to the formatted
5816 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5822 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5825 va_start(args, pat);
5826 sv_vsetpvf(sv, pat, &args);
5831 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5833 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5837 =for apidoc sv_setpvf_mg
5839 Like C<sv_setpvf>, but also handles 'set' magic.
5845 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5848 va_start(args, pat);
5849 sv_vsetpvf_mg(sv, pat, &args);
5854 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5856 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5860 #if defined(PERL_IMPLICIT_CONTEXT)
5862 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5866 va_start(args, pat);
5867 sv_vcatpvf(sv, pat, &args);
5872 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5876 va_start(args, pat);
5877 sv_vcatpvf_mg(sv, pat, &args);
5883 =for apidoc sv_catpvf
5885 Processes its arguments like C<sprintf> and appends the formatted output
5886 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5887 typically be called after calling this function to handle 'set' magic.
5893 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5896 va_start(args, pat);
5897 sv_vcatpvf(sv, pat, &args);
5902 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5904 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5908 =for apidoc sv_catpvf_mg
5910 Like C<sv_catpvf>, but also handles 'set' magic.
5916 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5919 va_start(args, pat);
5920 sv_vcatpvf_mg(sv, pat, &args);
5925 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5927 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5932 =for apidoc sv_vsetpvfn
5934 Works like C<vcatpvfn> but copies the text into the SV instead of
5941 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5943 sv_setpvn(sv, "", 0);
5944 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5948 =for apidoc sv_vcatpvfn
5950 Processes its arguments like C<vsprintf> and appends the formatted output
5951 to an SV. Uses an array of SVs if the C style variable argument list is
5952 missing (NULL). When running with taint checks enabled, indicates via
5953 C<maybe_tainted> if results are untrustworthy (often due to the use of
5960 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5967 static char nullstr[] = "(null)";
5970 /* no matter what, this is a string now */
5971 (void)SvPV_force(sv, origlen);
5973 /* special-case "", "%s", and "%_" */
5976 if (patlen == 2 && pat[0] == '%') {
5980 char *s = va_arg(*args, char*);
5981 sv_catpv(sv, s ? s : nullstr);
5983 else if (svix < svmax) {
5984 sv_catsv(sv, *svargs);
5985 if (DO_UTF8(*svargs))
5991 argsv = va_arg(*args, SV*);
5992 sv_catsv(sv, argsv);
5997 /* See comment on '_' below */
6002 patend = (char*)pat + patlen;
6003 for (p = (char*)pat; p < patend; p = q) {
6006 bool vectorize = FALSE;
6013 bool has_precis = FALSE;
6015 bool is_utf = FALSE;
6018 U8 utf8buf[UTF8_MAXLEN+1];
6019 STRLEN esignlen = 0;
6021 char *eptr = Nullch;
6023 /* Times 4: a decimal digit takes more than 3 binary digits.
6024 * NV_DIG: mantissa takes than many decimal digits.
6025 * Plus 32: Playing safe. */
6026 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6027 /* large enough for "%#.#f" --chip */
6028 /* what about long double NVs? --jhi */
6031 U8 *vecstr = Null(U8*);
6043 STRLEN dotstrlen = 1;
6044 I32 epix = 0; /* explicit parameter index */
6045 I32 ewix = 0; /* explicit width index */
6046 bool asterisk = FALSE;
6048 for (q = p; q < patend && *q != '%'; ++q) ;
6050 sv_catpvn(sv, p, q - p);
6079 case '*': /* printf("%*vX",":",$ipv6addr) */
6084 vecsv = va_arg(*args, SV*);
6085 else if (svix < svmax)
6086 vecsv = svargs[svix++];
6089 dotstr = SvPVx(vecsv,dotstrlen);
6117 case '1': case '2': case '3':
6118 case '4': case '5': case '6':
6119 case '7': case '8': case '9':
6122 width = width * 10 + (*q++ - '0');
6124 if (asterisk && ewix == 0) {
6129 } else if (epix == 0) {
6141 i = va_arg(*args, int);
6143 i = (ewix ? ewix <= svmax : svix < svmax) ?
6144 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6146 width = (i < 0) ? -i : i;
6155 i = va_arg(*args, int);
6157 i = (ewix ? ewix <= svmax : svix < svmax)
6158 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6159 precis = (i < 0) ? 0 : i;
6165 precis = precis * 10 + (*q++ - '0');
6172 vecsv = va_arg(*args, SV*);
6173 vecstr = (U8*)SvPVx(vecsv,veclen);
6174 utf = DO_UTF8(vecsv);
6176 else if (epix ? epix <= svmax : svix < svmax) {
6177 vecsv = svargs[epix ? epix-1 : svix++];
6178 vecstr = (U8*)SvPVx(vecsv,veclen);
6179 utf = DO_UTF8(vecsv);
6190 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6201 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6202 if (*(q + 1) == 'l') { /* lld, llf */
6229 uv = va_arg(*args, int);
6231 uv = (epix ? epix <= svmax : svix < svmax) ?
6232 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6233 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6234 eptr = (char*)utf8buf;
6235 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6247 eptr = va_arg(*args, char*);
6249 #ifdef MACOS_TRADITIONAL
6250 /* On MacOS, %#s format is used for Pascal strings */
6255 elen = strlen(eptr);
6258 elen = sizeof nullstr - 1;
6261 else if (epix ? epix <= svmax : svix < svmax) {
6262 argsv = svargs[epix ? epix-1 : svix++];
6263 eptr = SvPVx(argsv, elen);
6264 if (DO_UTF8(argsv)) {
6265 if (has_precis && precis < elen) {
6267 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6270 if (width) { /* fudge width (can't fudge elen) */
6271 width += elen - sv_len_utf8(argsv);
6280 * The "%_" hack might have to be changed someday,
6281 * if ISO or ANSI decide to use '_' for something.
6282 * So we keep it hidden from users' code.
6286 argsv = va_arg(*args,SV*);
6287 eptr = SvPVx(argsv, elen);
6293 if (has_precis && elen > precis)
6303 uv = PTR2UV(va_arg(*args, void*));
6305 uv = (epix ? epix <= svmax : svix < svmax) ?
6306 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
6326 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
6336 case 'h': iv = (short)va_arg(*args, int); break;
6337 default: iv = va_arg(*args, int); break;
6338 case 'l': iv = va_arg(*args, long); break;
6339 case 'V': iv = va_arg(*args, IV); break;
6341 case 'q': iv = va_arg(*args, Quad_t); break;
6346 iv = (epix ? epix <= svmax : svix < svmax) ?
6347 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6349 case 'h': iv = (short)iv; break;
6351 case 'l': iv = (long)iv; break;
6354 case 'q': iv = (Quad_t)iv; break;
6361 esignbuf[esignlen++] = plus;
6365 esignbuf[esignlen++] = '-';
6409 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
6419 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6420 default: uv = va_arg(*args, unsigned); break;
6421 case 'l': uv = va_arg(*args, unsigned long); break;
6422 case 'V': uv = va_arg(*args, UV); break;
6424 case 'q': uv = va_arg(*args, Quad_t); break;
6429 uv = (epix ? epix <= svmax : svix < svmax) ?
6430 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
6432 case 'h': uv = (unsigned short)uv; break;
6434 case 'l': uv = (unsigned long)uv; break;
6437 case 'q': uv = (Quad_t)uv; break;
6443 eptr = ebuf + sizeof ebuf;
6449 p = (char*)((c == 'X')
6450 ? "0123456789ABCDEF" : "0123456789abcdef");
6456 esignbuf[esignlen++] = '0';
6457 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6463 *--eptr = '0' + dig;
6465 if (alt && *eptr != '0')
6471 *--eptr = '0' + dig;
6474 esignbuf[esignlen++] = '0';
6475 esignbuf[esignlen++] = 'b';
6478 default: /* it had better be ten or less */
6479 #if defined(PERL_Y2KWARN)
6480 if (ckWARN(WARN_Y2K)) {
6482 char *s = SvPV(sv,n);
6483 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6484 && (n == 2 || !isDIGIT(s[n-3])))
6486 Perl_warner(aTHX_ WARN_Y2K,
6487 "Possible Y2K bug: %%%c %s",
6488 c, "format string following '19'");
6494 *--eptr = '0' + dig;
6495 } while (uv /= base);
6498 elen = (ebuf + sizeof ebuf) - eptr;
6501 zeros = precis - elen;
6502 else if (precis == 0 && elen == 1 && *eptr == '0')
6507 /* FLOATING POINT */
6510 c = 'f'; /* maybe %F isn't supported here */
6516 /* This is evil, but floating point is even more evil */
6520 nv = va_arg(*args, NV);
6522 nv = (epix ? epix <= svmax : svix < svmax) ?
6523 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
6526 if (c != 'e' && c != 'E') {
6528 (void)Perl_frexp(nv, &i);
6529 if (i == PERL_INT_MIN)
6530 Perl_die(aTHX_ "panic: frexp");
6532 need = BIT_DIGITS(i);
6534 need += has_precis ? precis : 6; /* known default */
6538 need += 20; /* fudge factor */
6539 if (PL_efloatsize < need) {
6540 Safefree(PL_efloatbuf);
6541 PL_efloatsize = need + 20; /* more fudge */
6542 New(906, PL_efloatbuf, PL_efloatsize, char);
6543 PL_efloatbuf[0] = '\0';
6546 eptr = ebuf + sizeof ebuf;
6549 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
6551 /* Copy the one or more characters in a long double
6552 * format before the 'base' ([efgEFG]) character to
6553 * the format string. */
6554 static char const prifldbl[] = PERL_PRIfldbl;
6555 char const *p = prifldbl + sizeof(prifldbl) - 3;
6556 while (p >= prifldbl) { *--eptr = *p--; }
6561 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6566 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6578 /* No taint. Otherwise we are in the strange situation
6579 * where printf() taints but print($float) doesn't.
6581 (void)sprintf(PL_efloatbuf, eptr, nv);
6583 eptr = PL_efloatbuf;
6584 elen = strlen(PL_efloatbuf);
6591 i = SvCUR(sv) - origlen;
6594 case 'h': *(va_arg(*args, short*)) = i; break;
6595 default: *(va_arg(*args, int*)) = i; break;
6596 case 'l': *(va_arg(*args, long*)) = i; break;
6597 case 'V': *(va_arg(*args, IV*)) = i; break;
6599 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6603 else if (epix ? epix <= svmax : svix < svmax)
6604 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
6605 continue; /* not "break" */
6612 if (!args && ckWARN(WARN_PRINTF) &&
6613 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6614 SV *msg = sv_newmortal();
6615 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6616 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6619 Perl_sv_catpvf(aTHX_ msg,
6620 "\"%%%c\"", c & 0xFF);
6622 Perl_sv_catpvf(aTHX_ msg,
6623 "\"%%\\%03"UVof"\"",
6626 sv_catpv(msg, "end of string");
6627 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6630 /* output mangled stuff ... */
6636 /* ... right here, because formatting flags should not apply */
6637 SvGROW(sv, SvCUR(sv) + elen + 1);
6639 memcpy(p, eptr, elen);
6642 SvCUR(sv) = p - SvPVX(sv);
6643 continue; /* not "break" */
6646 have = esignlen + zeros + elen;
6647 need = (have > width ? have : width);
6650 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6652 if (esignlen && fill == '0') {
6653 for (i = 0; i < esignlen; i++)
6657 memset(p, fill, gap);
6660 if (esignlen && fill != '0') {
6661 for (i = 0; i < esignlen; i++)
6665 for (i = zeros; i; i--)
6669 memcpy(p, eptr, elen);
6673 memset(p, ' ', gap);
6678 memcpy(p, dotstr, dotstrlen);
6682 vectorize = FALSE; /* done iterating over vecstr */
6687 SvCUR(sv) = p - SvPVX(sv);
6695 #if defined(USE_ITHREADS)
6697 #if defined(USE_THREADS)
6698 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6701 #ifndef GpREFCNT_inc
6702 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6706 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6707 #define av_dup(s) (AV*)sv_dup((SV*)s)
6708 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6709 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6710 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6711 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6712 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6713 #define io_dup(s) (IO*)sv_dup((SV*)s)
6714 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6715 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6716 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6717 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6718 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6721 Perl_re_dup(pTHX_ REGEXP *r)
6723 /* XXX fix when pmop->op_pmregexp becomes shared */
6724 return ReREFCNT_inc(r);
6728 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6732 return (PerlIO*)NULL;
6734 /* look for it in the table first */
6735 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6739 /* create anew and remember what it is */
6740 ret = PerlIO_fdupopen(fp);
6741 ptr_table_store(PL_ptr_table, fp, ret);
6746 Perl_dirp_dup(pTHX_ DIR *dp)
6755 Perl_gp_dup(pTHX_ GP *gp)
6760 /* look for it in the table first */
6761 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6765 /* create anew and remember what it is */
6766 Newz(0, ret, 1, GP);
6767 ptr_table_store(PL_ptr_table, gp, ret);
6770 ret->gp_refcnt = 0; /* must be before any other dups! */
6771 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6772 ret->gp_io = io_dup_inc(gp->gp_io);
6773 ret->gp_form = cv_dup_inc(gp->gp_form);
6774 ret->gp_av = av_dup_inc(gp->gp_av);
6775 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6776 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6777 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6778 ret->gp_cvgen = gp->gp_cvgen;
6779 ret->gp_flags = gp->gp_flags;
6780 ret->gp_line = gp->gp_line;
6781 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6786 Perl_mg_dup(pTHX_ MAGIC *mg)
6788 MAGIC *mgret = (MAGIC*)NULL;
6791 return (MAGIC*)NULL;
6792 /* look for it in the table first */
6793 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6797 for (; mg; mg = mg->mg_moremagic) {
6799 Newz(0, nmg, 1, MAGIC);
6803 mgprev->mg_moremagic = nmg;
6804 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6805 nmg->mg_private = mg->mg_private;
6806 nmg->mg_type = mg->mg_type;
6807 nmg->mg_flags = mg->mg_flags;
6808 if (mg->mg_type == 'r') {
6809 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6812 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6813 ? sv_dup_inc(mg->mg_obj)
6814 : sv_dup(mg->mg_obj);
6816 nmg->mg_len = mg->mg_len;
6817 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6818 if (mg->mg_ptr && mg->mg_type != 'g') {
6819 if (mg->mg_len >= 0) {
6820 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6821 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6822 AMT *amtp = (AMT*)mg->mg_ptr;
6823 AMT *namtp = (AMT*)nmg->mg_ptr;
6825 for (i = 1; i < NofAMmeth; i++) {
6826 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6830 else if (mg->mg_len == HEf_SVKEY)
6831 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6839 Perl_ptr_table_new(pTHX)
6842 Newz(0, tbl, 1, PTR_TBL_t);
6845 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6850 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6852 PTR_TBL_ENT_t *tblent;
6853 UV hash = PTR2UV(sv);
6855 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6856 for (; tblent; tblent = tblent->next) {
6857 if (tblent->oldval == sv)
6858 return tblent->newval;
6864 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6866 PTR_TBL_ENT_t *tblent, **otblent;
6867 /* XXX this may be pessimal on platforms where pointers aren't good
6868 * hash values e.g. if they grow faster in the most significant
6870 UV hash = PTR2UV(oldv);
6874 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6875 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6876 if (tblent->oldval == oldv) {
6877 tblent->newval = newv;
6882 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6883 tblent->oldval = oldv;
6884 tblent->newval = newv;
6885 tblent->next = *otblent;
6888 if (i && tbl->tbl_items > tbl->tbl_max)
6889 ptr_table_split(tbl);
6893 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6895 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6896 UV oldsize = tbl->tbl_max + 1;
6897 UV newsize = oldsize * 2;
6900 Renew(ary, newsize, PTR_TBL_ENT_t*);
6901 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6902 tbl->tbl_max = --newsize;
6904 for (i=0; i < oldsize; i++, ary++) {
6905 PTR_TBL_ENT_t **curentp, **entp, *ent;
6908 curentp = ary + oldsize;
6909 for (entp = ary, ent = *ary; ent; ent = *entp) {
6910 if ((newsize & PTR2UV(ent->oldval)) != i) {
6912 ent->next = *curentp;
6927 Perl_sv_dup(pTHX_ SV *sstr)
6931 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6933 /* look for it in the table first */
6934 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6938 /* create anew and remember what it is */
6940 ptr_table_store(PL_ptr_table, sstr, dstr);
6943 SvFLAGS(dstr) = SvFLAGS(sstr);
6944 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6945 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6948 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6949 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6950 PL_watch_pvx, SvPVX(sstr));
6953 switch (SvTYPE(sstr)) {
6958 SvANY(dstr) = new_XIV();
6959 SvIVX(dstr) = SvIVX(sstr);
6962 SvANY(dstr) = new_XNV();
6963 SvNVX(dstr) = SvNVX(sstr);
6966 SvANY(dstr) = new_XRV();
6967 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6970 SvANY(dstr) = new_XPV();
6971 SvCUR(dstr) = SvCUR(sstr);
6972 SvLEN(dstr) = SvLEN(sstr);
6974 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6975 else if (SvPVX(sstr) && SvLEN(sstr))
6976 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6978 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6981 SvANY(dstr) = new_XPVIV();
6982 SvCUR(dstr) = SvCUR(sstr);
6983 SvLEN(dstr) = SvLEN(sstr);
6984 SvIVX(dstr) = SvIVX(sstr);
6986 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6987 else if (SvPVX(sstr) && SvLEN(sstr))
6988 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6990 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6993 SvANY(dstr) = new_XPVNV();
6994 SvCUR(dstr) = SvCUR(sstr);
6995 SvLEN(dstr) = SvLEN(sstr);
6996 SvIVX(dstr) = SvIVX(sstr);
6997 SvNVX(dstr) = SvNVX(sstr);
6999 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7000 else if (SvPVX(sstr) && SvLEN(sstr))
7001 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7003 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7006 SvANY(dstr) = new_XPVMG();
7007 SvCUR(dstr) = SvCUR(sstr);
7008 SvLEN(dstr) = SvLEN(sstr);
7009 SvIVX(dstr) = SvIVX(sstr);
7010 SvNVX(dstr) = SvNVX(sstr);
7011 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7012 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7014 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7015 else if (SvPVX(sstr) && SvLEN(sstr))
7016 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7018 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7021 SvANY(dstr) = new_XPVBM();
7022 SvCUR(dstr) = SvCUR(sstr);
7023 SvLEN(dstr) = SvLEN(sstr);
7024 SvIVX(dstr) = SvIVX(sstr);
7025 SvNVX(dstr) = SvNVX(sstr);
7026 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7027 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7029 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7030 else if (SvPVX(sstr) && SvLEN(sstr))
7031 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7033 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7034 BmRARE(dstr) = BmRARE(sstr);
7035 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7036 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7039 SvANY(dstr) = new_XPVLV();
7040 SvCUR(dstr) = SvCUR(sstr);
7041 SvLEN(dstr) = SvLEN(sstr);
7042 SvIVX(dstr) = SvIVX(sstr);
7043 SvNVX(dstr) = SvNVX(sstr);
7044 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7045 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7047 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7048 else if (SvPVX(sstr) && SvLEN(sstr))
7049 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7051 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7052 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7053 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7054 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7055 LvTYPE(dstr) = LvTYPE(sstr);
7058 SvANY(dstr) = new_XPVGV();
7059 SvCUR(dstr) = SvCUR(sstr);
7060 SvLEN(dstr) = SvLEN(sstr);
7061 SvIVX(dstr) = SvIVX(sstr);
7062 SvNVX(dstr) = SvNVX(sstr);
7063 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7064 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7066 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7067 else if (SvPVX(sstr) && SvLEN(sstr))
7068 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7070 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7071 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7072 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7073 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7074 GvFLAGS(dstr) = GvFLAGS(sstr);
7075 GvGP(dstr) = gp_dup(GvGP(sstr));
7076 (void)GpREFCNT_inc(GvGP(dstr));
7079 SvANY(dstr) = new_XPVIO();
7080 SvCUR(dstr) = SvCUR(sstr);
7081 SvLEN(dstr) = SvLEN(sstr);
7082 SvIVX(dstr) = SvIVX(sstr);
7083 SvNVX(dstr) = SvNVX(sstr);
7084 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7085 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7087 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7088 else if (SvPVX(sstr) && SvLEN(sstr))
7089 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7091 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7092 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7093 if (IoOFP(sstr) == IoIFP(sstr))
7094 IoOFP(dstr) = IoIFP(dstr);
7096 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7097 /* PL_rsfp_filters entries have fake IoDIRP() */
7098 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7099 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7101 IoDIRP(dstr) = IoDIRP(sstr);
7102 IoLINES(dstr) = IoLINES(sstr);
7103 IoPAGE(dstr) = IoPAGE(sstr);
7104 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7105 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7106 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7107 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7108 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7109 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7110 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7111 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7112 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7113 IoTYPE(dstr) = IoTYPE(sstr);
7114 IoFLAGS(dstr) = IoFLAGS(sstr);
7117 SvANY(dstr) = new_XPVAV();
7118 SvCUR(dstr) = SvCUR(sstr);
7119 SvLEN(dstr) = SvLEN(sstr);
7120 SvIVX(dstr) = SvIVX(sstr);
7121 SvNVX(dstr) = SvNVX(sstr);
7122 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7123 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7124 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7125 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7126 if (AvARRAY((AV*)sstr)) {
7127 SV **dst_ary, **src_ary;
7128 SSize_t items = AvFILLp((AV*)sstr) + 1;
7130 src_ary = AvARRAY((AV*)sstr);
7131 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7132 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7133 SvPVX(dstr) = (char*)dst_ary;
7134 AvALLOC((AV*)dstr) = dst_ary;
7135 if (AvREAL((AV*)sstr)) {
7137 *dst_ary++ = sv_dup_inc(*src_ary++);
7141 *dst_ary++ = sv_dup(*src_ary++);
7143 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7144 while (items-- > 0) {
7145 *dst_ary++ = &PL_sv_undef;
7149 SvPVX(dstr) = Nullch;
7150 AvALLOC((AV*)dstr) = (SV**)NULL;
7154 SvANY(dstr) = new_XPVHV();
7155 SvCUR(dstr) = SvCUR(sstr);
7156 SvLEN(dstr) = SvLEN(sstr);
7157 SvIVX(dstr) = SvIVX(sstr);
7158 SvNVX(dstr) = SvNVX(sstr);
7159 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7160 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7161 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7162 if (HvARRAY((HV*)sstr)) {
7164 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7165 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7166 Newz(0, dxhv->xhv_array,
7167 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7168 while (i <= sxhv->xhv_max) {
7169 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7170 !!HvSHAREKEYS(sstr));
7173 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7176 SvPVX(dstr) = Nullch;
7177 HvEITER((HV*)dstr) = (HE*)NULL;
7179 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7180 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7183 SvANY(dstr) = new_XPVFM();
7184 FmLINES(dstr) = FmLINES(sstr);
7188 SvANY(dstr) = new_XPVCV();
7190 SvCUR(dstr) = SvCUR(sstr);
7191 SvLEN(dstr) = SvLEN(sstr);
7192 SvIVX(dstr) = SvIVX(sstr);
7193 SvNVX(dstr) = SvNVX(sstr);
7194 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7195 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7196 if (SvPVX(sstr) && SvLEN(sstr))
7197 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7199 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7200 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7201 CvSTART(dstr) = CvSTART(sstr);
7202 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7203 CvXSUB(dstr) = CvXSUB(sstr);
7204 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7205 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7206 CvDEPTH(dstr) = CvDEPTH(sstr);
7207 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7208 /* XXX padlists are real, but pretend to be not */
7209 AvREAL_on(CvPADLIST(sstr));
7210 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7211 AvREAL_off(CvPADLIST(sstr));
7212 AvREAL_off(CvPADLIST(dstr));
7215 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7216 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7217 CvFLAGS(dstr) = CvFLAGS(sstr);
7220 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7224 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7231 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7236 return (PERL_CONTEXT*)NULL;
7238 /* look for it in the table first */
7239 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7243 /* create anew and remember what it is */
7244 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7245 ptr_table_store(PL_ptr_table, cxs, ncxs);
7248 PERL_CONTEXT *cx = &cxs[ix];
7249 PERL_CONTEXT *ncx = &ncxs[ix];
7250 ncx->cx_type = cx->cx_type;
7251 if (CxTYPE(cx) == CXt_SUBST) {
7252 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7255 ncx->blk_oldsp = cx->blk_oldsp;
7256 ncx->blk_oldcop = cx->blk_oldcop;
7257 ncx->blk_oldretsp = cx->blk_oldretsp;
7258 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7259 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7260 ncx->blk_oldpm = cx->blk_oldpm;
7261 ncx->blk_gimme = cx->blk_gimme;
7262 switch (CxTYPE(cx)) {
7264 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7265 ? cv_dup_inc(cx->blk_sub.cv)
7266 : cv_dup(cx->blk_sub.cv));
7267 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7268 ? av_dup_inc(cx->blk_sub.argarray)
7270 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7271 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7272 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7273 ncx->blk_sub.lval = cx->blk_sub.lval;
7276 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7277 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7278 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7279 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7280 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7283 ncx->blk_loop.label = cx->blk_loop.label;
7284 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7285 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7286 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7287 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7288 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7289 ? cx->blk_loop.iterdata
7290 : gv_dup((GV*)cx->blk_loop.iterdata));
7291 ncx->blk_loop.oldcurpad
7292 = (SV**)ptr_table_fetch(PL_ptr_table,
7293 cx->blk_loop.oldcurpad);
7294 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7295 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7296 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7297 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7298 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7301 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7302 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7303 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7304 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7317 Perl_si_dup(pTHX_ PERL_SI *si)
7322 return (PERL_SI*)NULL;
7324 /* look for it in the table first */
7325 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7329 /* create anew and remember what it is */
7330 Newz(56, nsi, 1, PERL_SI);
7331 ptr_table_store(PL_ptr_table, si, nsi);
7333 nsi->si_stack = av_dup_inc(si->si_stack);
7334 nsi->si_cxix = si->si_cxix;
7335 nsi->si_cxmax = si->si_cxmax;
7336 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7337 nsi->si_type = si->si_type;
7338 nsi->si_prev = si_dup(si->si_prev);
7339 nsi->si_next = si_dup(si->si_next);
7340 nsi->si_markoff = si->si_markoff;
7345 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7346 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7347 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7348 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7349 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7350 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7351 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7352 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7353 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7354 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7355 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7356 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7359 #define pv_dup_inc(p) SAVEPV(p)
7360 #define pv_dup(p) SAVEPV(p)
7361 #define svp_dup_inc(p,pp) any_dup(p,pp)
7364 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7371 /* look for it in the table first */
7372 ret = ptr_table_fetch(PL_ptr_table, v);
7376 /* see if it is part of the interpreter structure */
7377 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7378 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7386 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7388 ANY *ss = proto_perl->Tsavestack;
7389 I32 ix = proto_perl->Tsavestack_ix;
7390 I32 max = proto_perl->Tsavestack_max;
7403 void (*dptr) (void*);
7404 void (*dxptr) (pTHXo_ void*);
7407 Newz(54, nss, max, ANY);
7413 case SAVEt_ITEM: /* normal string */
7414 sv = (SV*)POPPTR(ss,ix);
7415 TOPPTR(nss,ix) = sv_dup_inc(sv);
7416 sv = (SV*)POPPTR(ss,ix);
7417 TOPPTR(nss,ix) = sv_dup_inc(sv);
7419 case SAVEt_SV: /* scalar reference */
7420 sv = (SV*)POPPTR(ss,ix);
7421 TOPPTR(nss,ix) = sv_dup_inc(sv);
7422 gv = (GV*)POPPTR(ss,ix);
7423 TOPPTR(nss,ix) = gv_dup_inc(gv);
7425 case SAVEt_GENERIC_PVREF: /* generic char* */
7426 c = (char*)POPPTR(ss,ix);
7427 TOPPTR(nss,ix) = pv_dup(c);
7428 ptr = POPPTR(ss,ix);
7429 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7431 case SAVEt_GENERIC_SVREF: /* generic sv */
7432 case SAVEt_SVREF: /* scalar reference */
7433 sv = (SV*)POPPTR(ss,ix);
7434 TOPPTR(nss,ix) = sv_dup_inc(sv);
7435 ptr = POPPTR(ss,ix);
7436 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7438 case SAVEt_AV: /* array reference */
7439 av = (AV*)POPPTR(ss,ix);
7440 TOPPTR(nss,ix) = av_dup_inc(av);
7441 gv = (GV*)POPPTR(ss,ix);
7442 TOPPTR(nss,ix) = gv_dup(gv);
7444 case SAVEt_HV: /* hash reference */
7445 hv = (HV*)POPPTR(ss,ix);
7446 TOPPTR(nss,ix) = hv_dup_inc(hv);
7447 gv = (GV*)POPPTR(ss,ix);
7448 TOPPTR(nss,ix) = gv_dup(gv);
7450 case SAVEt_INT: /* int reference */
7451 ptr = POPPTR(ss,ix);
7452 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7453 intval = (int)POPINT(ss,ix);
7454 TOPINT(nss,ix) = intval;
7456 case SAVEt_LONG: /* long reference */
7457 ptr = POPPTR(ss,ix);
7458 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7459 longval = (long)POPLONG(ss,ix);
7460 TOPLONG(nss,ix) = longval;
7462 case SAVEt_I32: /* I32 reference */
7463 case SAVEt_I16: /* I16 reference */
7464 case SAVEt_I8: /* I8 reference */
7465 ptr = POPPTR(ss,ix);
7466 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7470 case SAVEt_IV: /* IV reference */
7471 ptr = POPPTR(ss,ix);
7472 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7476 case SAVEt_SPTR: /* SV* reference */
7477 ptr = POPPTR(ss,ix);
7478 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7479 sv = (SV*)POPPTR(ss,ix);
7480 TOPPTR(nss,ix) = sv_dup(sv);
7482 case SAVEt_VPTR: /* random* reference */
7483 ptr = POPPTR(ss,ix);
7484 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7485 ptr = POPPTR(ss,ix);
7486 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7488 case SAVEt_PPTR: /* char* reference */
7489 ptr = POPPTR(ss,ix);
7490 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7491 c = (char*)POPPTR(ss,ix);
7492 TOPPTR(nss,ix) = pv_dup(c);
7494 case SAVEt_HPTR: /* HV* reference */
7495 ptr = POPPTR(ss,ix);
7496 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7497 hv = (HV*)POPPTR(ss,ix);
7498 TOPPTR(nss,ix) = hv_dup(hv);
7500 case SAVEt_APTR: /* AV* reference */
7501 ptr = POPPTR(ss,ix);
7502 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7503 av = (AV*)POPPTR(ss,ix);
7504 TOPPTR(nss,ix) = av_dup(av);
7507 gv = (GV*)POPPTR(ss,ix);
7508 TOPPTR(nss,ix) = gv_dup(gv);
7510 case SAVEt_GP: /* scalar reference */
7511 gp = (GP*)POPPTR(ss,ix);
7512 TOPPTR(nss,ix) = gp = gp_dup(gp);
7513 (void)GpREFCNT_inc(gp);
7514 gv = (GV*)POPPTR(ss,ix);
7515 TOPPTR(nss,ix) = gv_dup_inc(c);
7516 c = (char*)POPPTR(ss,ix);
7517 TOPPTR(nss,ix) = pv_dup(c);
7524 sv = (SV*)POPPTR(ss,ix);
7525 TOPPTR(nss,ix) = sv_dup_inc(sv);
7528 ptr = POPPTR(ss,ix);
7529 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7530 /* these are assumed to be refcounted properly */
7531 switch (((OP*)ptr)->op_type) {
7538 TOPPTR(nss,ix) = ptr;
7543 TOPPTR(nss,ix) = Nullop;
7548 TOPPTR(nss,ix) = Nullop;
7551 c = (char*)POPPTR(ss,ix);
7552 TOPPTR(nss,ix) = pv_dup_inc(c);
7555 longval = POPLONG(ss,ix);
7556 TOPLONG(nss,ix) = longval;
7559 hv = (HV*)POPPTR(ss,ix);
7560 TOPPTR(nss,ix) = hv_dup_inc(hv);
7561 c = (char*)POPPTR(ss,ix);
7562 TOPPTR(nss,ix) = pv_dup_inc(c);
7566 case SAVEt_DESTRUCTOR:
7567 ptr = POPPTR(ss,ix);
7568 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7569 dptr = POPDPTR(ss,ix);
7570 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7572 case SAVEt_DESTRUCTOR_X:
7573 ptr = POPPTR(ss,ix);
7574 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7575 dxptr = POPDXPTR(ss,ix);
7576 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7578 case SAVEt_REGCONTEXT:
7584 case SAVEt_STACK_POS: /* Position on Perl stack */
7588 case SAVEt_AELEM: /* array element */
7589 sv = (SV*)POPPTR(ss,ix);
7590 TOPPTR(nss,ix) = sv_dup_inc(sv);
7593 av = (AV*)POPPTR(ss,ix);
7594 TOPPTR(nss,ix) = av_dup_inc(av);
7596 case SAVEt_HELEM: /* hash element */
7597 sv = (SV*)POPPTR(ss,ix);
7598 TOPPTR(nss,ix) = sv_dup_inc(sv);
7599 sv = (SV*)POPPTR(ss,ix);
7600 TOPPTR(nss,ix) = sv_dup_inc(sv);
7601 hv = (HV*)POPPTR(ss,ix);
7602 TOPPTR(nss,ix) = hv_dup_inc(hv);
7605 ptr = POPPTR(ss,ix);
7606 TOPPTR(nss,ix) = ptr;
7613 av = (AV*)POPPTR(ss,ix);
7614 TOPPTR(nss,ix) = av_dup(av);
7617 longval = (long)POPLONG(ss,ix);
7618 TOPLONG(nss,ix) = longval;
7619 ptr = POPPTR(ss,ix);
7620 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7621 sv = (SV*)POPPTR(ss,ix);
7622 TOPPTR(nss,ix) = sv_dup(sv);
7625 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7637 perl_clone(PerlInterpreter *proto_perl, UV flags)
7640 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7643 #ifdef PERL_IMPLICIT_SYS
7644 return perl_clone_using(proto_perl, flags,
7646 proto_perl->IMemShared,
7647 proto_perl->IMemParse,
7657 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7658 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7659 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7660 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7661 struct IPerlDir* ipD, struct IPerlSock* ipS,
7662 struct IPerlProc* ipP)
7664 /* XXX many of the string copies here can be optimized if they're
7665 * constants; they need to be allocated as common memory and just
7666 * their pointers copied. */
7670 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7672 PERL_SET_THX(pPerl);
7673 # else /* !PERL_OBJECT */
7674 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7675 PERL_SET_THX(my_perl);
7678 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7683 # else /* !DEBUGGING */
7684 Zero(my_perl, 1, PerlInterpreter);
7685 # endif /* DEBUGGING */
7689 PL_MemShared = ipMS;
7697 # endif /* PERL_OBJECT */
7698 #else /* !PERL_IMPLICIT_SYS */
7700 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7701 PERL_SET_THX(my_perl);
7704 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7709 # else /* !DEBUGGING */
7710 Zero(my_perl, 1, PerlInterpreter);
7711 # endif /* DEBUGGING */
7712 #endif /* PERL_IMPLICIT_SYS */
7715 PL_xiv_arenaroot = NULL;
7717 PL_xnv_arenaroot = NULL;
7719 PL_xrv_arenaroot = NULL;
7721 PL_xpv_arenaroot = NULL;
7723 PL_xpviv_arenaroot = NULL;
7724 PL_xpviv_root = NULL;
7725 PL_xpvnv_arenaroot = NULL;
7726 PL_xpvnv_root = NULL;
7727 PL_xpvcv_arenaroot = NULL;
7728 PL_xpvcv_root = NULL;
7729 PL_xpvav_arenaroot = NULL;
7730 PL_xpvav_root = NULL;
7731 PL_xpvhv_arenaroot = NULL;
7732 PL_xpvhv_root = NULL;
7733 PL_xpvmg_arenaroot = NULL;
7734 PL_xpvmg_root = NULL;
7735 PL_xpvlv_arenaroot = NULL;
7736 PL_xpvlv_root = NULL;
7737 PL_xpvbm_arenaroot = NULL;
7738 PL_xpvbm_root = NULL;
7739 PL_he_arenaroot = NULL;
7741 PL_nice_chunk = NULL;
7742 PL_nice_chunk_size = 0;
7745 PL_sv_root = Nullsv;
7746 PL_sv_arenaroot = Nullsv;
7748 PL_debug = proto_perl->Idebug;
7750 /* create SV map for pointer relocation */
7751 PL_ptr_table = ptr_table_new();
7753 /* initialize these special pointers as early as possible */
7754 SvANY(&PL_sv_undef) = NULL;
7755 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7756 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7757 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7760 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7762 SvANY(&PL_sv_no) = new_XPVNV();
7764 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7765 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7766 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7767 SvCUR(&PL_sv_no) = 0;
7768 SvLEN(&PL_sv_no) = 1;
7769 SvNVX(&PL_sv_no) = 0;
7770 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7773 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7775 SvANY(&PL_sv_yes) = new_XPVNV();
7777 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7778 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7779 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7780 SvCUR(&PL_sv_yes) = 1;
7781 SvLEN(&PL_sv_yes) = 2;
7782 SvNVX(&PL_sv_yes) = 1;
7783 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7785 /* create shared string table */
7786 PL_strtab = newHV();
7787 HvSHAREKEYS_off(PL_strtab);
7788 hv_ksplit(PL_strtab, 512);
7789 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7791 PL_compiling = proto_perl->Icompiling;
7792 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7793 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7794 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7795 if (!specialWARN(PL_compiling.cop_warnings))
7796 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7797 if (!specialCopIO(PL_compiling.cop_io))
7798 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
7799 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7801 /* pseudo environmental stuff */
7802 PL_origargc = proto_perl->Iorigargc;
7804 New(0, PL_origargv, i+1, char*);
7805 PL_origargv[i] = '\0';
7807 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7809 PL_envgv = gv_dup(proto_perl->Ienvgv);
7810 PL_incgv = gv_dup(proto_perl->Iincgv);
7811 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7812 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7813 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7814 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7817 PL_minus_c = proto_perl->Iminus_c;
7818 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7819 PL_localpatches = proto_perl->Ilocalpatches;
7820 PL_splitstr = proto_perl->Isplitstr;
7821 PL_preprocess = proto_perl->Ipreprocess;
7822 PL_minus_n = proto_perl->Iminus_n;
7823 PL_minus_p = proto_perl->Iminus_p;
7824 PL_minus_l = proto_perl->Iminus_l;
7825 PL_minus_a = proto_perl->Iminus_a;
7826 PL_minus_F = proto_perl->Iminus_F;
7827 PL_doswitches = proto_perl->Idoswitches;
7828 PL_dowarn = proto_perl->Idowarn;
7829 PL_doextract = proto_perl->Idoextract;
7830 PL_sawampersand = proto_perl->Isawampersand;
7831 PL_unsafe = proto_perl->Iunsafe;
7832 PL_inplace = SAVEPV(proto_perl->Iinplace);
7833 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7834 PL_perldb = proto_perl->Iperldb;
7835 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7837 /* magical thingies */
7838 /* XXX time(&PL_basetime) when asked for? */
7839 PL_basetime = proto_perl->Ibasetime;
7840 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7842 PL_maxsysfd = proto_perl->Imaxsysfd;
7843 PL_multiline = proto_perl->Imultiline;
7844 PL_statusvalue = proto_perl->Istatusvalue;
7846 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7849 /* shortcuts to various I/O objects */
7850 PL_stdingv = gv_dup(proto_perl->Istdingv);
7851 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7852 PL_defgv = gv_dup(proto_perl->Idefgv);
7853 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7854 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7855 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7857 /* shortcuts to regexp stuff */
7858 PL_replgv = gv_dup(proto_perl->Ireplgv);
7860 /* shortcuts to misc objects */
7861 PL_errgv = gv_dup(proto_perl->Ierrgv);
7863 /* shortcuts to debugging objects */
7864 PL_DBgv = gv_dup(proto_perl->IDBgv);
7865 PL_DBline = gv_dup(proto_perl->IDBline);
7866 PL_DBsub = gv_dup(proto_perl->IDBsub);
7867 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7868 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7869 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7870 PL_lineary = av_dup(proto_perl->Ilineary);
7871 PL_dbargs = av_dup(proto_perl->Idbargs);
7874 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7875 PL_curstash = hv_dup(proto_perl->Tcurstash);
7876 PL_debstash = hv_dup(proto_perl->Idebstash);
7877 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7878 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7880 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7881 PL_endav = av_dup_inc(proto_perl->Iendav);
7882 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7883 PL_initav = av_dup_inc(proto_perl->Iinitav);
7885 PL_sub_generation = proto_perl->Isub_generation;
7887 /* funky return mechanisms */
7888 PL_forkprocess = proto_perl->Iforkprocess;
7890 /* subprocess state */
7891 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7893 /* internal state */
7894 PL_tainting = proto_perl->Itainting;
7895 PL_maxo = proto_perl->Imaxo;
7896 if (proto_perl->Iop_mask)
7897 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7899 PL_op_mask = Nullch;
7901 /* current interpreter roots */
7902 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7903 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7904 PL_main_start = proto_perl->Imain_start;
7905 PL_eval_root = proto_perl->Ieval_root;
7906 PL_eval_start = proto_perl->Ieval_start;
7908 /* runtime control stuff */
7909 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7910 PL_copline = proto_perl->Icopline;
7912 PL_filemode = proto_perl->Ifilemode;
7913 PL_lastfd = proto_perl->Ilastfd;
7914 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7917 PL_gensym = proto_perl->Igensym;
7918 PL_preambled = proto_perl->Ipreambled;
7919 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7920 PL_laststatval = proto_perl->Ilaststatval;
7921 PL_laststype = proto_perl->Ilaststype;
7922 PL_mess_sv = Nullsv;
7924 PL_orslen = proto_perl->Iorslen;
7925 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7926 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7928 /* interpreter atexit processing */
7929 PL_exitlistlen = proto_perl->Iexitlistlen;
7930 if (PL_exitlistlen) {
7931 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7932 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7935 PL_exitlist = (PerlExitListEntry*)NULL;
7936 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7938 PL_profiledata = NULL;
7939 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7940 /* PL_rsfp_filters entries have fake IoDIRP() */
7941 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7943 PL_compcv = cv_dup(proto_perl->Icompcv);
7944 PL_comppad = av_dup(proto_perl->Icomppad);
7945 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7946 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7947 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7948 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7949 proto_perl->Tcurpad);
7951 #ifdef HAVE_INTERP_INTERN
7952 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7955 /* more statics moved here */
7956 PL_generation = proto_perl->Igeneration;
7957 PL_DBcv = cv_dup(proto_perl->IDBcv);
7959 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7960 PL_in_clean_all = proto_perl->Iin_clean_all;
7962 PL_uid = proto_perl->Iuid;
7963 PL_euid = proto_perl->Ieuid;
7964 PL_gid = proto_perl->Igid;
7965 PL_egid = proto_perl->Iegid;
7966 PL_nomemok = proto_perl->Inomemok;
7967 PL_an = proto_perl->Ian;
7968 PL_cop_seqmax = proto_perl->Icop_seqmax;
7969 PL_op_seqmax = proto_perl->Iop_seqmax;
7970 PL_evalseq = proto_perl->Ievalseq;
7971 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7972 PL_origalen = proto_perl->Iorigalen;
7973 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7974 PL_osname = SAVEPV(proto_perl->Iosname);
7975 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7976 PL_sighandlerp = proto_perl->Isighandlerp;
7979 PL_runops = proto_perl->Irunops;
7981 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7984 PL_cshlen = proto_perl->Icshlen;
7985 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7988 PL_lex_state = proto_perl->Ilex_state;
7989 PL_lex_defer = proto_perl->Ilex_defer;
7990 PL_lex_expect = proto_perl->Ilex_expect;
7991 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7992 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7993 PL_lex_starts = proto_perl->Ilex_starts;
7994 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7995 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7996 PL_lex_op = proto_perl->Ilex_op;
7997 PL_lex_inpat = proto_perl->Ilex_inpat;
7998 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7999 PL_lex_brackets = proto_perl->Ilex_brackets;
8000 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8001 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8002 PL_lex_casemods = proto_perl->Ilex_casemods;
8003 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8004 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8006 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8007 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8008 PL_nexttoke = proto_perl->Inexttoke;
8010 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8011 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8012 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8013 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8014 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8015 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8016 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8017 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8018 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8019 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8020 PL_pending_ident = proto_perl->Ipending_ident;
8021 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8023 PL_expect = proto_perl->Iexpect;
8025 PL_multi_start = proto_perl->Imulti_start;
8026 PL_multi_end = proto_perl->Imulti_end;
8027 PL_multi_open = proto_perl->Imulti_open;
8028 PL_multi_close = proto_perl->Imulti_close;
8030 PL_error_count = proto_perl->Ierror_count;
8031 PL_subline = proto_perl->Isubline;
8032 PL_subname = sv_dup_inc(proto_perl->Isubname);
8034 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8035 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8036 PL_padix = proto_perl->Ipadix;
8037 PL_padix_floor = proto_perl->Ipadix_floor;
8038 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8040 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8041 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8042 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8043 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8044 PL_last_lop_op = proto_perl->Ilast_lop_op;
8045 PL_in_my = proto_perl->Iin_my;
8046 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8048 PL_cryptseen = proto_perl->Icryptseen;
8051 PL_hints = proto_perl->Ihints;
8053 PL_amagic_generation = proto_perl->Iamagic_generation;
8055 #ifdef USE_LOCALE_COLLATE
8056 PL_collation_ix = proto_perl->Icollation_ix;
8057 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8058 PL_collation_standard = proto_perl->Icollation_standard;
8059 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8060 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8061 #endif /* USE_LOCALE_COLLATE */
8063 #ifdef USE_LOCALE_NUMERIC
8064 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8065 PL_numeric_standard = proto_perl->Inumeric_standard;
8066 PL_numeric_local = proto_perl->Inumeric_local;
8067 PL_numeric_radix = proto_perl->Inumeric_radix;
8068 #endif /* !USE_LOCALE_NUMERIC */
8070 /* utf8 character classes */
8071 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8072 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8073 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8074 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8075 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8076 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8077 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8078 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8079 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8080 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8081 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8082 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8083 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8084 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8085 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8086 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8087 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8090 PL_last_swash_hv = Nullhv; /* reinits on demand */
8091 PL_last_swash_klen = 0;
8092 PL_last_swash_key[0]= '\0';
8093 PL_last_swash_tmps = (U8*)NULL;
8094 PL_last_swash_slen = 0;
8096 /* perly.c globals */
8097 PL_yydebug = proto_perl->Iyydebug;
8098 PL_yynerrs = proto_perl->Iyynerrs;
8099 PL_yyerrflag = proto_perl->Iyyerrflag;
8100 PL_yychar = proto_perl->Iyychar;
8101 PL_yyval = proto_perl->Iyyval;
8102 PL_yylval = proto_perl->Iyylval;
8104 PL_glob_index = proto_perl->Iglob_index;
8105 PL_srand_called = proto_perl->Isrand_called;
8106 PL_uudmap['M'] = 0; /* reinits on demand */
8107 PL_bitcount = Nullch; /* reinits on demand */
8109 if (proto_perl->Ipsig_ptr) {
8110 int sig_num[] = { SIG_NUM };
8111 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8112 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8113 for (i = 1; PL_sig_name[i]; i++) {
8114 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8115 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8119 PL_psig_ptr = (SV**)NULL;
8120 PL_psig_name = (SV**)NULL;
8123 /* thrdvar.h stuff */
8126 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8127 PL_tmps_ix = proto_perl->Ttmps_ix;
8128 PL_tmps_max = proto_perl->Ttmps_max;
8129 PL_tmps_floor = proto_perl->Ttmps_floor;
8130 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8132 while (i <= PL_tmps_ix) {
8133 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8137 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8138 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8139 Newz(54, PL_markstack, i, I32);
8140 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8141 - proto_perl->Tmarkstack);
8142 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8143 - proto_perl->Tmarkstack);
8144 Copy(proto_perl->Tmarkstack, PL_markstack,
8145 PL_markstack_ptr - PL_markstack + 1, I32);
8147 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8148 * NOTE: unlike the others! */
8149 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8150 PL_scopestack_max = proto_perl->Tscopestack_max;
8151 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8152 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8154 /* next push_return() sets PL_retstack[PL_retstack_ix]
8155 * NOTE: unlike the others! */
8156 PL_retstack_ix = proto_perl->Tretstack_ix;
8157 PL_retstack_max = proto_perl->Tretstack_max;
8158 Newz(54, PL_retstack, PL_retstack_max, OP*);
8159 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8161 /* NOTE: si_dup() looks at PL_markstack */
8162 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8164 /* PL_curstack = PL_curstackinfo->si_stack; */
8165 PL_curstack = av_dup(proto_perl->Tcurstack);
8166 PL_mainstack = av_dup(proto_perl->Tmainstack);
8168 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8169 PL_stack_base = AvARRAY(PL_curstack);
8170 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8171 - proto_perl->Tstack_base);
8172 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8174 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8175 * NOTE: unlike the others! */
8176 PL_savestack_ix = proto_perl->Tsavestack_ix;
8177 PL_savestack_max = proto_perl->Tsavestack_max;
8178 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8179 PL_savestack = ss_dup(proto_perl);
8183 ENTER; /* perl_destruct() wants to LEAVE; */
8186 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8187 PL_top_env = &PL_start_env;
8189 PL_op = proto_perl->Top;
8192 PL_Xpv = (XPV*)NULL;
8193 PL_na = proto_perl->Tna;
8195 PL_statbuf = proto_perl->Tstatbuf;
8196 PL_statcache = proto_perl->Tstatcache;
8197 PL_statgv = gv_dup(proto_perl->Tstatgv);
8198 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8200 PL_timesbuf = proto_perl->Ttimesbuf;
8203 PL_tainted = proto_perl->Ttainted;
8204 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8205 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8206 PL_rs = sv_dup_inc(proto_perl->Trs);
8207 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8208 PL_ofslen = proto_perl->Tofslen;
8209 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8210 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8211 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8212 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8213 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8214 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8216 PL_restartop = proto_perl->Trestartop;
8217 PL_in_eval = proto_perl->Tin_eval;
8218 PL_delaymagic = proto_perl->Tdelaymagic;
8219 PL_dirty = proto_perl->Tdirty;
8220 PL_localizing = proto_perl->Tlocalizing;
8222 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8223 PL_protect = proto_perl->Tprotect;
8225 PL_errors = sv_dup_inc(proto_perl->Terrors);
8226 PL_av_fetch_sv = Nullsv;
8227 PL_hv_fetch_sv = Nullsv;
8228 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8229 PL_modcount = proto_perl->Tmodcount;
8230 PL_lastgotoprobe = Nullop;
8231 PL_dumpindent = proto_perl->Tdumpindent;
8233 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8234 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8235 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8236 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8237 PL_sortcxix = proto_perl->Tsortcxix;
8238 PL_efloatbuf = Nullch; /* reinits on demand */
8239 PL_efloatsize = 0; /* reinits on demand */
8243 PL_screamfirst = NULL;
8244 PL_screamnext = NULL;
8245 PL_maxscream = -1; /* reinits on demand */
8246 PL_lastscream = Nullsv;
8248 PL_watchaddr = NULL;
8249 PL_watchok = Nullch;
8251 PL_regdummy = proto_perl->Tregdummy;
8252 PL_regcomp_parse = Nullch;
8253 PL_regxend = Nullch;
8254 PL_regcode = (regnode*)NULL;
8257 PL_regprecomp = Nullch;
8262 PL_seen_zerolen = 0;
8264 PL_regcomp_rx = (regexp*)NULL;
8266 PL_colorset = 0; /* reinits PL_colors[] */
8267 /*PL_colors[6] = {0,0,0,0,0,0};*/
8268 PL_reg_whilem_seen = 0;
8269 PL_reginput = Nullch;
8272 PL_regstartp = (I32*)NULL;
8273 PL_regendp = (I32*)NULL;
8274 PL_reglastparen = (U32*)NULL;
8275 PL_regtill = Nullch;
8277 PL_reg_start_tmp = (char**)NULL;
8278 PL_reg_start_tmpl = 0;
8279 PL_regdata = (struct reg_data*)NULL;
8282 PL_reg_eval_set = 0;
8284 PL_regprogram = (regnode*)NULL;
8286 PL_regcc = (CURCUR*)NULL;
8287 PL_reg_call_cc = (struct re_cc_state*)NULL;
8288 PL_reg_re = (regexp*)NULL;
8289 PL_reg_ganch = Nullch;
8291 PL_reg_magic = (MAGIC*)NULL;
8293 PL_reg_oldcurpm = (PMOP*)NULL;
8294 PL_reg_curpm = (PMOP*)NULL;
8295 PL_reg_oldsaved = Nullch;
8296 PL_reg_oldsavedlen = 0;
8298 PL_reg_leftiter = 0;
8299 PL_reg_poscache = Nullch;
8300 PL_reg_poscache_size= 0;
8302 /* RE engine - function pointers */
8303 PL_regcompp = proto_perl->Tregcompp;
8304 PL_regexecp = proto_perl->Tregexecp;
8305 PL_regint_start = proto_perl->Tregint_start;
8306 PL_regint_string = proto_perl->Tregint_string;
8307 PL_regfree = proto_perl->Tregfree;
8309 PL_reginterp_cnt = 0;
8310 PL_reg_starttry = 0;
8313 return (PerlInterpreter*)pPerl;
8319 #else /* !USE_ITHREADS */
8325 #endif /* USE_ITHREADS */
8328 do_report_used(pTHXo_ SV *sv)
8330 if (SvTYPE(sv) != SVTYPEMASK) {
8331 PerlIO_printf(Perl_debug_log, "****\n");
8337 do_clean_objs(pTHXo_ SV *sv)
8341 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8342 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8343 if (SvWEAKREF(sv)) {
8354 /* XXX Might want to check arrays, etc. */
8357 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8359 do_clean_named_objs(pTHXo_ SV *sv)
8361 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8362 if ( SvOBJECT(GvSV(sv)) ||
8363 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8364 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8365 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8366 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8368 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8376 do_clean_all(pTHXo_ SV *sv)
8378 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8379 SvFLAGS(sv) |= SVf_BREAK;