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 (SvTYPE(sv) == mt)
922 switch (SvTYPE(sv)) {
943 else if (mt < SVt_PVIV)
960 pv = (char*)SvRV(sv);
980 else if (mt == SVt_NV)
991 del_XPVIV(SvANY(sv));
1001 del_XPVNV(SvANY(sv));
1009 magic = SvMAGIC(sv);
1010 stash = SvSTASH(sv);
1011 del_XPVMG(SvANY(sv));
1014 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1019 Perl_croak(aTHX_ "Can't upgrade to undef");
1021 SvANY(sv) = new_XIV();
1025 SvANY(sv) = new_XNV();
1029 SvANY(sv) = new_XRV();
1033 SvANY(sv) = new_XPV();
1039 SvANY(sv) = new_XPVIV();
1049 SvANY(sv) = new_XPVNV();
1057 SvANY(sv) = new_XPVMG();
1063 SvMAGIC(sv) = magic;
1064 SvSTASH(sv) = stash;
1067 SvANY(sv) = new_XPVLV();
1073 SvMAGIC(sv) = magic;
1074 SvSTASH(sv) = stash;
1081 SvANY(sv) = new_XPVAV();
1089 SvMAGIC(sv) = magic;
1090 SvSTASH(sv) = stash;
1096 SvANY(sv) = new_XPVHV();
1104 SvMAGIC(sv) = magic;
1105 SvSTASH(sv) = stash;
1112 SvANY(sv) = new_XPVCV();
1113 Zero(SvANY(sv), 1, XPVCV);
1119 SvMAGIC(sv) = magic;
1120 SvSTASH(sv) = stash;
1123 SvANY(sv) = new_XPVGV();
1129 SvMAGIC(sv) = magic;
1130 SvSTASH(sv) = stash;
1138 SvANY(sv) = new_XPVBM();
1144 SvMAGIC(sv) = magic;
1145 SvSTASH(sv) = stash;
1151 SvANY(sv) = new_XPVFM();
1152 Zero(SvANY(sv), 1, XPVFM);
1158 SvMAGIC(sv) = magic;
1159 SvSTASH(sv) = stash;
1162 SvANY(sv) = new_XPVIO();
1163 Zero(SvANY(sv), 1, XPVIO);
1169 SvMAGIC(sv) = magic;
1170 SvSTASH(sv) = stash;
1171 IoPAGE_LEN(sv) = 60;
1174 SvFLAGS(sv) &= ~SVTYPEMASK;
1180 Perl_sv_backoff(pTHX_ register SV *sv)
1184 char *s = SvPVX(sv);
1185 SvLEN(sv) += SvIVX(sv);
1186 SvPVX(sv) -= SvIVX(sv);
1188 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1190 SvFLAGS(sv) &= ~SVf_OOK;
1197 Expands the character buffer in the SV. This will use C<sv_unref> and will
1198 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1205 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1209 #ifdef HAS_64K_LIMIT
1210 if (newlen >= 0x10000) {
1211 PerlIO_printf(Perl_debug_log,
1212 "Allocation too large: %"UVxf"\n", (UV)newlen);
1215 #endif /* HAS_64K_LIMIT */
1218 if (SvTYPE(sv) < SVt_PV) {
1219 sv_upgrade(sv, SVt_PV);
1222 else if (SvOOK(sv)) { /* pv is offset? */
1225 if (newlen > SvLEN(sv))
1226 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1227 #ifdef HAS_64K_LIMIT
1228 if (newlen >= 0x10000)
1234 if (newlen > SvLEN(sv)) { /* need more room? */
1235 if (SvLEN(sv) && s) {
1236 #if defined(MYMALLOC) && !defined(LEAKTEST)
1237 STRLEN l = malloced_size((void*)SvPVX(sv));
1243 Renew(s,newlen,char);
1246 New(703,s,newlen,char);
1248 SvLEN_set(sv, newlen);
1254 =for apidoc sv_setiv
1256 Copies an integer into the given SV. Does not handle 'set' magic. See
1263 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1265 SV_CHECK_THINKFIRST(sv);
1266 switch (SvTYPE(sv)) {
1268 sv_upgrade(sv, SVt_IV);
1271 sv_upgrade(sv, SVt_PVNV);
1275 sv_upgrade(sv, SVt_PVIV);
1286 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1287 PL_op_desc[PL_op->op_type]);
1290 (void)SvIOK_only(sv); /* validate number */
1296 =for apidoc sv_setiv_mg
1298 Like C<sv_setiv>, but also handles 'set' magic.
1304 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1311 =for apidoc sv_setuv
1313 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1320 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1328 =for apidoc sv_setuv_mg
1330 Like C<sv_setuv>, but also handles 'set' magic.
1336 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1343 =for apidoc sv_setnv
1345 Copies a double into the given SV. Does not handle 'set' magic. See
1352 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1354 SV_CHECK_THINKFIRST(sv);
1355 switch (SvTYPE(sv)) {
1358 sv_upgrade(sv, SVt_NV);
1363 sv_upgrade(sv, SVt_PVNV);
1374 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1375 PL_op_name[PL_op->op_type]);
1379 (void)SvNOK_only(sv); /* validate number */
1384 =for apidoc sv_setnv_mg
1386 Like C<sv_setnv>, but also handles 'set' magic.
1392 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1399 S_not_a_number(pTHX_ SV *sv)
1405 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1406 /* each *s can expand to 4 chars + "...\0",
1407 i.e. need room for 8 chars */
1409 for (s = SvPVX(sv); *s && d < limit; s++) {
1411 if (ch & 128 && !isPRINT_LC(ch)) {
1420 else if (ch == '\r') {
1424 else if (ch == '\f') {
1428 else if (ch == '\\') {
1432 else if (isPRINT_LC(ch))
1447 Perl_warner(aTHX_ WARN_NUMERIC,
1448 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1449 PL_op_desc[PL_op->op_type]);
1451 Perl_warner(aTHX_ WARN_NUMERIC,
1452 "Argument \"%s\" isn't numeric", tmpbuf);
1455 /* the number can be converted to integer with atol() or atoll() */
1456 #define IS_NUMBER_TO_INT_BY_ATOL 0x01
1457 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */
1458 #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */
1459 #define IS_NUMBER_NEG 0x08 /* not good to cache UV */
1460 #define IS_NUMBER_INFINITY 0x10 /* this is big */
1462 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1463 until proven guilty, assume that things are not that bad... */
1466 Perl_sv_2iv(pTHX_ register SV *sv)
1470 if (SvGMAGICAL(sv)) {
1475 return I_V(SvNVX(sv));
1477 if (SvPOKp(sv) && SvLEN(sv))
1480 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1482 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1488 if (SvTHINKFIRST(sv)) {
1491 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1492 return SvIV(tmpstr);
1493 return PTR2IV(SvRV(sv));
1495 if (SvREADONLY(sv) && !SvOK(sv)) {
1497 if (ckWARN(WARN_UNINITIALIZED))
1504 return (IV)(SvUVX(sv));
1511 /* We can cache the IV/UV value even if it not good enough
1512 * to reconstruct NV, since the conversion to PV will prefer
1516 if (SvTYPE(sv) == SVt_NV)
1517 sv_upgrade(sv, SVt_PVNV);
1520 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1521 SvIVX(sv) = I_V(SvNVX(sv));
1523 SvUVX(sv) = U_V(SvNVX(sv));
1526 DEBUG_c(PerlIO_printf(Perl_debug_log,
1527 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1531 return (IV)SvUVX(sv);
1534 else if (SvPOKp(sv) && SvLEN(sv)) {
1535 I32 numtype = looks_like_number(sv);
1537 /* We want to avoid a possible problem when we cache an IV which
1538 may be later translated to an NV, and the resulting NV is not
1539 the translation of the initial data.
1541 This means that if we cache such an IV, we need to cache the
1542 NV as well. Moreover, we trade speed for space, and do not
1543 cache the NV if not needed.
1545 if (numtype & IS_NUMBER_NOT_IV) {
1546 /* May be not an integer. Need to cache NV if we cache IV
1547 * - otherwise future conversion to NV will be wrong. */
1550 d = Atof(SvPVX(sv));
1552 if (SvTYPE(sv) < SVt_PVNV)
1553 sv_upgrade(sv, SVt_PVNV);
1557 #if defined(USE_LONG_DOUBLE)
1558 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1559 PTR2UV(sv), SvNVX(sv)));
1561 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1562 PTR2UV(sv), SvNVX(sv)));
1564 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1565 SvIVX(sv) = I_V(SvNVX(sv));
1567 SvUVX(sv) = U_V(SvNVX(sv));
1573 /* The NV may be reconstructed from IV - safe to cache IV,
1574 which may be calculated by atol(). */
1575 if (SvTYPE(sv) == SVt_PV)
1576 sv_upgrade(sv, SVt_PVIV);
1578 SvIVX(sv) = Atol(SvPVX(sv));
1580 else { /* Not a number. Cache 0. */
1583 if (SvTYPE(sv) < SVt_PVIV)
1584 sv_upgrade(sv, SVt_PVIV);
1587 if (ckWARN(WARN_NUMERIC))
1593 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1595 if (SvTYPE(sv) < SVt_IV)
1596 /* Typically the caller expects that sv_any is not NULL now. */
1597 sv_upgrade(sv, SVt_IV);
1600 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1601 PTR2UV(sv),SvIVX(sv)));
1602 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1606 Perl_sv_2uv(pTHX_ register SV *sv)
1610 if (SvGMAGICAL(sv)) {
1615 return U_V(SvNVX(sv));
1616 if (SvPOKp(sv) && SvLEN(sv))
1619 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1621 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1627 if (SvTHINKFIRST(sv)) {
1630 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv, numer)))
1631 return SvUV(tmpstr);
1632 return PTR2UV(SvRV(sv));
1634 if (SvREADONLY(sv) && !SvOK(sv)) {
1636 if (ckWARN(WARN_UNINITIALIZED))
1646 return (UV)SvIVX(sv);
1650 /* We can cache the IV/UV value even if it not good enough
1651 * to reconstruct NV, since the conversion to PV will prefer
1654 if (SvTYPE(sv) == SVt_NV)
1655 sv_upgrade(sv, SVt_PVNV);
1657 if (SvNVX(sv) >= -0.5) {
1659 SvUVX(sv) = U_V(SvNVX(sv));
1662 SvIVX(sv) = I_V(SvNVX(sv));
1664 DEBUG_c(PerlIO_printf(Perl_debug_log,
1665 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1668 (IV)(UV)SvIVX(sv)));
1669 return (UV)SvIVX(sv);
1672 else if (SvPOKp(sv) && SvLEN(sv)) {
1673 I32 numtype = looks_like_number(sv);
1675 /* We want to avoid a possible problem when we cache a UV which
1676 may be later translated to an NV, and the resulting NV is not
1677 the translation of the initial data.
1679 This means that if we cache such a UV, we need to cache the
1680 NV as well. Moreover, we trade speed for space, and do not
1681 cache the NV if not needed.
1683 if (numtype & IS_NUMBER_NOT_IV) {
1684 /* May be not an integer. Need to cache NV if we cache IV
1685 * - otherwise future conversion to NV will be wrong. */
1688 d = Atof(SvPVX(sv));
1690 if (SvTYPE(sv) < SVt_PVNV)
1691 sv_upgrade(sv, SVt_PVNV);
1695 #if defined(USE_LONG_DOUBLE)
1696 DEBUG_c(PerlIO_printf(Perl_debug_log,
1697 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1698 PTR2UV(sv), SvNVX(sv)));
1700 DEBUG_c(PerlIO_printf(Perl_debug_log,
1701 "0x%"UVxf" 2nv(%g)\n",
1702 PTR2UV(sv), SvNVX(sv)));
1704 if (SvNVX(sv) < -0.5) {
1705 SvIVX(sv) = I_V(SvNVX(sv));
1708 SvUVX(sv) = U_V(SvNVX(sv));
1712 else if (numtype & IS_NUMBER_NEG) {
1713 /* The NV may be reconstructed from IV - safe to cache IV,
1714 which may be calculated by atol(). */
1715 if (SvTYPE(sv) == SVt_PV)
1716 sv_upgrade(sv, SVt_PVIV);
1718 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1720 else if (numtype) { /* Non-negative */
1721 /* The NV may be reconstructed from UV - safe to cache UV,
1722 which may be calculated by strtoul()/atol. */
1723 if (SvTYPE(sv) == SVt_PV)
1724 sv_upgrade(sv, SVt_PVIV);
1726 (void)SvIsUV_on(sv);
1728 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1729 #else /* no atou(), but we know the number fits into IV... */
1730 /* The only problem may be if it is negative... */
1731 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1734 else { /* Not a number. Cache 0. */
1737 if (SvTYPE(sv) < SVt_PVIV)
1738 sv_upgrade(sv, SVt_PVIV);
1740 (void)SvIsUV_on(sv);
1741 SvUVX(sv) = 0; /* We assume that 0s have the
1742 same bitmap in IV and UV. */
1743 if (ckWARN(WARN_NUMERIC))
1748 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1750 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1753 if (SvTYPE(sv) < SVt_IV)
1754 /* Typically the caller expects that sv_any is not NULL now. */
1755 sv_upgrade(sv, SVt_IV);
1759 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1760 PTR2UV(sv),SvUVX(sv)));
1761 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1765 Perl_sv_2nv(pTHX_ register SV *sv)
1769 if (SvGMAGICAL(sv)) {
1773 if (SvPOKp(sv) && SvLEN(sv)) {
1775 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1777 return Atof(SvPVX(sv));
1781 return (NV)SvUVX(sv);
1783 return (NV)SvIVX(sv);
1786 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1788 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1794 if (SvTHINKFIRST(sv)) {
1797 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)))
1798 return SvNV(tmpstr);
1799 return PTR2NV(SvRV(sv));
1801 if (SvREADONLY(sv) && !SvOK(sv)) {
1803 if (ckWARN(WARN_UNINITIALIZED))
1808 if (SvTYPE(sv) < SVt_NV) {
1809 if (SvTYPE(sv) == SVt_IV)
1810 sv_upgrade(sv, SVt_PVNV);
1812 sv_upgrade(sv, SVt_NV);
1813 #if defined(USE_LONG_DOUBLE)
1815 RESTORE_NUMERIC_STANDARD();
1816 PerlIO_printf(Perl_debug_log,
1817 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1818 PTR2UV(sv), SvNVX(sv));
1819 RESTORE_NUMERIC_LOCAL();
1823 RESTORE_NUMERIC_STANDARD();
1824 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1825 PTR2UV(sv), SvNVX(sv));
1826 RESTORE_NUMERIC_LOCAL();
1830 else if (SvTYPE(sv) < SVt_PVNV)
1831 sv_upgrade(sv, SVt_PVNV);
1833 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1835 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1837 else if (SvPOKp(sv) && SvLEN(sv)) {
1839 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1841 SvNVX(sv) = Atof(SvPVX(sv));
1845 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1847 if (SvTYPE(sv) < SVt_NV)
1848 /* Typically the caller expects that sv_any is not NULL now. */
1849 sv_upgrade(sv, SVt_NV);
1853 #if defined(USE_LONG_DOUBLE)
1855 RESTORE_NUMERIC_STANDARD();
1856 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1857 PTR2UV(sv), SvNVX(sv));
1858 RESTORE_NUMERIC_LOCAL();
1862 RESTORE_NUMERIC_STANDARD();
1863 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1864 PTR2UV(sv), SvNVX(sv));
1865 RESTORE_NUMERIC_LOCAL();
1872 S_asIV(pTHX_ SV *sv)
1874 I32 numtype = looks_like_number(sv);
1877 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1878 return Atol(SvPVX(sv));
1881 if (ckWARN(WARN_NUMERIC))
1884 d = Atof(SvPVX(sv));
1889 S_asUV(pTHX_ SV *sv)
1891 I32 numtype = looks_like_number(sv);
1894 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1895 return Strtoul(SvPVX(sv), Null(char**), 10);
1899 if (ckWARN(WARN_NUMERIC))
1902 return U_V(Atof(SvPVX(sv)));
1906 * Returns a combination of (advisory only - can get false negatives)
1907 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1909 * 0 if does not look like number.
1911 * In fact possible values are 0 and
1912 * IS_NUMBER_TO_INT_BY_ATOL 123
1913 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1914 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1915 * IS_NUMBER_INFINITY
1916 * with a possible addition of IS_NUMBER_NEG.
1920 =for apidoc looks_like_number
1922 Test if an the content of an SV looks like a number (or is a
1929 Perl_looks_like_number(pTHX_ SV *sv)
1932 register char *send;
1933 register char *sbegin;
1934 register char *nbegin;
1943 else if (SvPOKp(sv))
1944 sbegin = SvPV(sv, len);
1947 send = sbegin + len;
1954 numtype = IS_NUMBER_NEG;
1961 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1962 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1966 /* next must be digit or the radix separator or beginning of infinity */
1970 } while (isDIGIT(*s));
1972 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1973 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1975 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1978 #ifdef USE_LOCALE_NUMERIC
1979 || IS_NUMERIC_RADIX(*s)
1983 numtype |= IS_NUMBER_NOT_IV;
1984 while (isDIGIT(*s)) /* optional digits after the radix */
1989 #ifdef USE_LOCALE_NUMERIC
1990 || IS_NUMERIC_RADIX(*s)
1994 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1995 /* no digits before the radix means we need digits after it */
1999 } while (isDIGIT(*s));
2004 else if (*s == 'I' || *s == 'i') {
2005 s++; if (*s != 'N' && *s != 'n') return 0;
2006 s++; if (*s != 'F' && *s != 'f') return 0;
2007 s++; if (*s == 'I' || *s == 'i') {
2008 s++; if (*s != 'N' && *s != 'n') return 0;
2009 s++; if (*s != 'I' && *s != 'i') return 0;
2010 s++; if (*s != 'T' && *s != 't') return 0;
2011 s++; if (*s != 'Y' && *s != 'y') return 0;
2019 numtype = IS_NUMBER_INFINITY;
2021 /* we can have an optional exponent part */
2022 if (*s == 'e' || *s == 'E') {
2023 numtype &= ~IS_NUMBER_NEG;
2024 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
2026 if (*s == '+' || *s == '-')
2031 } while (isDIGIT(*s));
2041 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2042 return IS_NUMBER_TO_INT_BY_ATOL;
2047 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2050 return sv_2pv(sv, &n_a);
2053 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2055 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2057 char *ptr = buf + TYPE_CHARS(UV);
2071 *--ptr = '0' + (uv % 10);
2080 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2085 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2086 char *tmpbuf = tbuf;
2092 if (SvGMAGICAL(sv)) {
2100 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2102 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2107 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2112 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2114 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2121 if (SvTHINKFIRST(sv)) {
2124 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)))
2125 return SvPV(tmpstr,*lp);
2132 switch (SvTYPE(sv)) {
2134 if ( ((SvFLAGS(sv) &
2135 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2136 == (SVs_OBJECT|SVs_RMG))
2137 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2138 && (mg = mg_find(sv, 'r'))) {
2140 regexp *re = (regexp *)mg->mg_obj;
2143 char *fptr = "msix";
2148 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2150 while((ch = *fptr++)) {
2152 reflags[left++] = ch;
2155 reflags[right--] = ch;
2160 reflags[left] = '-';
2164 mg->mg_len = re->prelen + 4 + left;
2165 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2166 Copy("(?", mg->mg_ptr, 2, char);
2167 Copy(reflags, mg->mg_ptr+2, left, char);
2168 Copy(":", mg->mg_ptr+left+2, 1, char);
2169 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2170 mg->mg_ptr[mg->mg_len - 1] = ')';
2171 mg->mg_ptr[mg->mg_len] = 0;
2173 PL_reginterp_cnt += re->program[0].next_off;
2185 case SVt_PVBM: s = "SCALAR"; break;
2186 case SVt_PVLV: s = "LVALUE"; break;
2187 case SVt_PVAV: s = "ARRAY"; break;
2188 case SVt_PVHV: s = "HASH"; break;
2189 case SVt_PVCV: s = "CODE"; break;
2190 case SVt_PVGV: s = "GLOB"; break;
2191 case SVt_PVFM: s = "FORMAT"; break;
2192 case SVt_PVIO: s = "IO"; break;
2193 default: s = "UNKNOWN"; break;
2197 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2200 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2206 if (SvREADONLY(sv) && !SvOK(sv)) {
2208 if (ckWARN(WARN_UNINITIALIZED))
2214 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2215 /* XXXX 64-bit? IV may have better precision... */
2216 /* I tried changing this for to be 64-bit-aware and
2217 * the t/op/numconvert.t became very, very, angry.
2219 if (SvTYPE(sv) < SVt_PVNV)
2220 sv_upgrade(sv, SVt_PVNV);
2223 olderrno = errno; /* some Xenix systems wipe out errno here */
2225 if (SvNVX(sv) == 0.0)
2226 (void)strcpy(s,"0");
2230 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2233 #ifdef FIXNEGATIVEZERO
2234 if (*s == '-' && s[1] == '0' && !s[2])
2243 else if (SvIOKp(sv)) {
2244 U32 isIOK = SvIOK(sv);
2245 U32 isUIOK = SvIsUV(sv);
2246 char buf[TYPE_CHARS(UV)];
2249 if (SvTYPE(sv) < SVt_PVIV)
2250 sv_upgrade(sv, SVt_PVIV);
2252 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2254 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2255 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2256 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2257 SvCUR_set(sv, ebuf - ptr);
2270 if (ckWARN(WARN_UNINITIALIZED)
2271 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2276 if (SvTYPE(sv) < SVt_PV)
2277 /* Typically the caller expects that sv_any is not NULL now. */
2278 sv_upgrade(sv, SVt_PV);
2281 *lp = s - SvPVX(sv);
2284 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2285 PTR2UV(sv),SvPVX(sv)));
2289 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2290 /* Sneaky stuff here */
2294 tsv = newSVpv(tmpbuf, 0);
2310 len = strlen(tmpbuf);
2312 #ifdef FIXNEGATIVEZERO
2313 if (len == 2 && t[0] == '-' && t[1] == '0') {
2318 (void)SvUPGRADE(sv, SVt_PV);
2320 s = SvGROW(sv, len + 1);
2329 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2332 return sv_2pvbyte(sv, &n_a);
2336 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2338 return sv_2pv(sv,lp);
2342 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2345 return sv_2pvutf8(sv, &n_a);
2349 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2351 sv_utf8_upgrade(sv);
2352 return sv_2pv(sv,lp);
2355 /* This function is only called on magical items */
2357 Perl_sv_2bool(pTHX_ register SV *sv)
2367 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2368 return SvTRUE(tmpsv);
2369 return SvRV(sv) != 0;
2372 register XPV* Xpvtmp;
2373 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2374 (*Xpvtmp->xpv_pv > '0' ||
2375 Xpvtmp->xpv_cur > 1 ||
2376 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2383 return SvIVX(sv) != 0;
2386 return SvNVX(sv) != 0.0;
2394 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2399 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2402 /* This function could be much more efficient if we had a FLAG
2403 * to signal if there are any hibit chars in the string
2406 for (c = SvPVX(sv); c < SvEND(sv); c++) {
2413 SvGROW(sv, SvCUR(sv) + hicount + 1);
2415 src = SvEND(sv) - 1;
2416 SvCUR_set(sv, SvCUR(sv) + hicount);
2417 dst = SvEND(sv) - 1;
2422 uv_to_utf8((U8*)dst, (U8)*src--);
2435 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2437 if (SvPOK(sv) && SvUTF8(sv)) {
2438 char *c = SvPVX(sv);
2440 /* need to figure out if this is possible at all first */
2441 while (c < SvEND(sv)) {
2444 UV uv = utf8_to_uv((U8*)c, &len);
2449 /* XXX might want to make a callback here instead */
2450 Perl_croak(aTHX_ "Big byte");
2463 char *src = first_hi;
2464 char *dst = first_hi;
2465 while (src < SvEND(sv)) {
2468 U8 u = (U8)utf8_to_uv((U8*)src, &len);
2476 SvCUR_set(sv, dst - SvPVX(sv));
2484 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2486 sv_utf8_upgrade(sv);
2491 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2495 bool has_utf = FALSE;
2496 if (!sv_utf8_downgrade(sv, TRUE))
2499 /* it is actually just a matter of turning the utf8 flag on, but
2500 * we want to make sure everything inside is valid utf8 first.
2503 while (c < SvEND(sv)) {
2506 (void)utf8_to_uv((U8*)c, &len);
2526 /* Note: sv_setsv() should not be called with a source string that needs
2527 * to be reused, since it may destroy the source string if it is marked
2532 =for apidoc sv_setsv
2534 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2535 The source SV may be destroyed if it is mortal. Does not handle 'set'
2536 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2543 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2546 register U32 sflags;
2552 SV_CHECK_THINKFIRST(dstr);
2554 sstr = &PL_sv_undef;
2555 stype = SvTYPE(sstr);
2556 dtype = SvTYPE(dstr);
2560 /* There's a lot of redundancy below but we're going for speed here */
2565 if (dtype != SVt_PVGV) {
2566 (void)SvOK_off(dstr);
2574 sv_upgrade(dstr, SVt_IV);
2577 sv_upgrade(dstr, SVt_PVNV);
2581 sv_upgrade(dstr, SVt_PVIV);
2584 (void)SvIOK_only(dstr);
2585 SvIVX(dstr) = SvIVX(sstr);
2598 sv_upgrade(dstr, SVt_NV);
2603 sv_upgrade(dstr, SVt_PVNV);
2606 SvNVX(dstr) = SvNVX(sstr);
2607 (void)SvNOK_only(dstr);
2615 sv_upgrade(dstr, SVt_RV);
2616 else if (dtype == SVt_PVGV &&
2617 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2620 if (GvIMPORTED(dstr) != GVf_IMPORTED
2621 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2623 GvIMPORTED_on(dstr);
2634 sv_upgrade(dstr, SVt_PV);
2637 if (dtype < SVt_PVIV)
2638 sv_upgrade(dstr, SVt_PVIV);
2641 if (dtype < SVt_PVNV)
2642 sv_upgrade(dstr, SVt_PVNV);
2649 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2650 PL_op_name[PL_op->op_type]);
2652 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2656 if (dtype <= SVt_PVGV) {
2658 if (dtype != SVt_PVGV) {
2659 char *name = GvNAME(sstr);
2660 STRLEN len = GvNAMELEN(sstr);
2661 sv_upgrade(dstr, SVt_PVGV);
2662 sv_magic(dstr, dstr, '*', name, len);
2663 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2664 GvNAME(dstr) = savepvn(name, len);
2665 GvNAMELEN(dstr) = len;
2666 SvFAKE_on(dstr); /* can coerce to non-glob */
2668 /* ahem, death to those who redefine active sort subs */
2669 else if (PL_curstackinfo->si_type == PERLSI_SORT
2670 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2671 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2673 (void)SvOK_off(dstr);
2674 GvINTRO_off(dstr); /* one-shot flag */
2676 GvGP(dstr) = gp_ref(GvGP(sstr));
2678 if (GvIMPORTED(dstr) != GVf_IMPORTED
2679 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2681 GvIMPORTED_on(dstr);
2689 if (SvGMAGICAL(sstr)) {
2691 if (SvTYPE(sstr) != stype) {
2692 stype = SvTYPE(sstr);
2693 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2697 if (stype == SVt_PVLV)
2698 (void)SvUPGRADE(dstr, SVt_PVNV);
2700 (void)SvUPGRADE(dstr, stype);
2703 sflags = SvFLAGS(sstr);
2705 if (sflags & SVf_ROK) {
2706 if (dtype >= SVt_PV) {
2707 if (dtype == SVt_PVGV) {
2708 SV *sref = SvREFCNT_inc(SvRV(sstr));
2710 int intro = GvINTRO(dstr);
2715 GvINTRO_off(dstr); /* one-shot flag */
2716 Newz(602,gp, 1, GP);
2717 GvGP(dstr) = gp_ref(gp);
2718 GvSV(dstr) = NEWSV(72,0);
2719 GvLINE(dstr) = CopLINE(PL_curcop);
2720 GvEGV(dstr) = (GV*)dstr;
2723 switch (SvTYPE(sref)) {
2726 SAVESPTR(GvAV(dstr));
2728 dref = (SV*)GvAV(dstr);
2729 GvAV(dstr) = (AV*)sref;
2730 if (!GvIMPORTED_AV(dstr)
2731 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2733 GvIMPORTED_AV_on(dstr);
2738 SAVESPTR(GvHV(dstr));
2740 dref = (SV*)GvHV(dstr);
2741 GvHV(dstr) = (HV*)sref;
2742 if (!GvIMPORTED_HV(dstr)
2743 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2745 GvIMPORTED_HV_on(dstr);
2750 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2751 SvREFCNT_dec(GvCV(dstr));
2752 GvCV(dstr) = Nullcv;
2753 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2754 PL_sub_generation++;
2756 SAVESPTR(GvCV(dstr));
2759 dref = (SV*)GvCV(dstr);
2760 if (GvCV(dstr) != (CV*)sref) {
2761 CV* cv = GvCV(dstr);
2763 if (!GvCVGEN((GV*)dstr) &&
2764 (CvROOT(cv) || CvXSUB(cv)))
2766 SV *const_sv = cv_const_sv(cv);
2767 bool const_changed = TRUE;
2769 const_changed = sv_cmp(const_sv,
2770 op_const_sv(CvSTART((CV*)sref),
2772 /* ahem, death to those who redefine
2773 * active sort subs */
2774 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2775 PL_sortcop == CvSTART(cv))
2777 "Can't redefine active sort subroutine %s",
2778 GvENAME((GV*)dstr));
2779 if ((const_changed || const_sv) && ckWARN(WARN_REDEFINE))
2780 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2781 "Constant subroutine %s redefined"
2782 : "Subroutine %s redefined",
2783 GvENAME((GV*)dstr));
2785 cv_ckproto(cv, (GV*)dstr,
2786 SvPOK(sref) ? SvPVX(sref) : Nullch);
2788 GvCV(dstr) = (CV*)sref;
2789 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2790 GvASSUMECV_on(dstr);
2791 PL_sub_generation++;
2793 if (!GvIMPORTED_CV(dstr)
2794 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2796 GvIMPORTED_CV_on(dstr);
2801 SAVESPTR(GvIOp(dstr));
2803 dref = (SV*)GvIOp(dstr);
2804 GvIOp(dstr) = (IO*)sref;
2808 SAVESPTR(GvSV(dstr));
2810 dref = (SV*)GvSV(dstr);
2812 if (!GvIMPORTED_SV(dstr)
2813 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2815 GvIMPORTED_SV_on(dstr);
2827 (void)SvOOK_off(dstr); /* backoff */
2829 Safefree(SvPVX(dstr));
2830 SvLEN(dstr)=SvCUR(dstr)=0;
2833 (void)SvOK_off(dstr);
2834 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2836 if (sflags & SVp_NOK) {
2838 SvNVX(dstr) = SvNVX(sstr);
2840 if (sflags & SVp_IOK) {
2841 (void)SvIOK_on(dstr);
2842 SvIVX(dstr) = SvIVX(sstr);
2843 if (sflags & SVf_IVisUV)
2846 if (SvAMAGIC(sstr)) {
2850 else if (sflags & SVp_POK) {
2853 * Check to see if we can just swipe the string. If so, it's a
2854 * possible small lose on short strings, but a big win on long ones.
2855 * It might even be a win on short strings if SvPVX(dstr)
2856 * has to be allocated and SvPVX(sstr) has to be freed.
2859 if (SvTEMP(sstr) && /* slated for free anyway? */
2860 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2861 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2863 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2865 SvFLAGS(dstr) &= ~SVf_OOK;
2866 Safefree(SvPVX(dstr) - SvIVX(dstr));
2868 else if (SvLEN(dstr))
2869 Safefree(SvPVX(dstr));
2871 (void)SvPOK_only(dstr);
2872 SvPV_set(dstr, SvPVX(sstr));
2873 SvLEN_set(dstr, SvLEN(sstr));
2874 SvCUR_set(dstr, SvCUR(sstr));
2877 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
2878 SvPV_set(sstr, Nullch);
2883 else { /* have to copy actual string */
2884 STRLEN len = SvCUR(sstr);
2886 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2887 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2888 SvCUR_set(dstr, len);
2889 *SvEND(dstr) = '\0';
2890 (void)SvPOK_only(dstr);
2892 if ((sflags & SVf_UTF8) && !IN_BYTE)
2895 if (sflags & SVp_NOK) {
2897 SvNVX(dstr) = SvNVX(sstr);
2899 if (sflags & SVp_IOK) {
2900 (void)SvIOK_on(dstr);
2901 SvIVX(dstr) = SvIVX(sstr);
2902 if (sflags & SVf_IVisUV)
2906 else if (sflags & SVp_NOK) {
2907 SvNVX(dstr) = SvNVX(sstr);
2908 (void)SvNOK_only(dstr);
2909 if (sflags & SVf_IOK) {
2910 (void)SvIOK_on(dstr);
2911 SvIVX(dstr) = SvIVX(sstr);
2912 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2913 if (sflags & SVf_IVisUV)
2917 else if (sflags & SVp_IOK) {
2918 (void)SvIOK_only(dstr);
2919 SvIVX(dstr) = SvIVX(sstr);
2920 if (sflags & SVf_IVisUV)
2924 if (dtype == SVt_PVGV) {
2925 if (ckWARN(WARN_MISC))
2926 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2929 (void)SvOK_off(dstr);
2935 =for apidoc sv_setsv_mg
2937 Like C<sv_setsv>, but also handles 'set' magic.
2943 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2945 sv_setsv(dstr,sstr);
2950 =for apidoc sv_setpvn
2952 Copies a string into an SV. The C<len> parameter indicates the number of
2953 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2959 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2961 register char *dptr;
2962 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2963 elicit a warning, but it won't hurt. */
2964 SV_CHECK_THINKFIRST(sv);
2969 (void)SvUPGRADE(sv, SVt_PV);
2971 SvGROW(sv, len + 1);
2973 Move(ptr,dptr,len,char);
2976 (void)SvPOK_only(sv); /* validate pointer */
2981 =for apidoc sv_setpvn_mg
2983 Like C<sv_setpvn>, but also handles 'set' magic.
2989 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2991 sv_setpvn(sv,ptr,len);
2996 =for apidoc sv_setpv
2998 Copies a string into an SV. The string must be null-terminated. Does not
2999 handle 'set' magic. See C<sv_setpv_mg>.
3005 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3007 register STRLEN len;
3009 SV_CHECK_THINKFIRST(sv);
3015 (void)SvUPGRADE(sv, SVt_PV);
3017 SvGROW(sv, len + 1);
3018 Move(ptr,SvPVX(sv),len+1,char);
3020 (void)SvPOK_only(sv); /* validate pointer */
3025 =for apidoc sv_setpv_mg
3027 Like C<sv_setpv>, but also handles 'set' magic.
3033 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3040 =for apidoc sv_usepvn
3042 Tells an SV to use C<ptr> to find its string value. Normally the string is
3043 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3044 The C<ptr> should point to memory that was allocated by C<malloc>. The
3045 string length, C<len>, must be supplied. This function will realloc the
3046 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3047 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3048 See C<sv_usepvn_mg>.
3054 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3056 SV_CHECK_THINKFIRST(sv);
3057 (void)SvUPGRADE(sv, SVt_PV);
3062 (void)SvOOK_off(sv);
3063 if (SvPVX(sv) && SvLEN(sv))
3064 Safefree(SvPVX(sv));
3065 Renew(ptr, len+1, char);
3068 SvLEN_set(sv, len+1);
3070 (void)SvPOK_only(sv); /* validate pointer */
3075 =for apidoc sv_usepvn_mg
3077 Like C<sv_usepvn>, but also handles 'set' magic.
3083 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3085 sv_usepvn(sv,ptr,len);
3090 Perl_sv_force_normal(pTHX_ register SV *sv)
3092 if (SvREADONLY(sv)) {
3094 if (PL_curcop != &PL_compiling)
3095 Perl_croak(aTHX_ PL_no_modify);
3099 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3106 Efficient removal of characters from the beginning of the string buffer.
3107 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3108 the string buffer. The C<ptr> becomes the first character of the adjusted
3115 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3119 register STRLEN delta;
3121 if (!ptr || !SvPOKp(sv))
3123 SV_CHECK_THINKFIRST(sv);
3124 if (SvTYPE(sv) < SVt_PVIV)
3125 sv_upgrade(sv,SVt_PVIV);
3128 if (!SvLEN(sv)) { /* make copy of shared string */
3129 char *pvx = SvPVX(sv);
3130 STRLEN len = SvCUR(sv);
3131 SvGROW(sv, len + 1);
3132 Move(pvx,SvPVX(sv),len,char);
3136 SvFLAGS(sv) |= SVf_OOK;
3138 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3139 delta = ptr - SvPVX(sv);
3147 =for apidoc sv_catpvn
3149 Concatenates the string onto the end of the string which is in the SV. The
3150 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3151 'set' magic. See C<sv_catpvn_mg>.
3157 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3162 junk = SvPV_force(sv, tlen);
3163 SvGROW(sv, tlen + len + 1);
3166 Move(ptr,SvPVX(sv)+tlen,len,char);
3169 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3174 =for apidoc sv_catpvn_mg
3176 Like C<sv_catpvn>, but also handles 'set' magic.
3182 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3184 sv_catpvn(sv,ptr,len);
3189 =for apidoc sv_catsv
3191 Concatenates the string from SV C<ssv> onto the end of the string in SV
3192 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3198 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3204 if ((s = SvPV(sstr, len))) {
3205 if (DO_UTF8(sstr)) {
3206 sv_utf8_upgrade(dstr);
3207 sv_catpvn(dstr,s,len);
3211 sv_catpvn(dstr,s,len);
3216 =for apidoc sv_catsv_mg
3218 Like C<sv_catsv>, but also handles 'set' magic.
3224 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3226 sv_catsv(dstr,sstr);
3231 =for apidoc sv_catpv
3233 Concatenates the string onto the end of the string which is in the SV.
3234 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3240 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3242 register STRLEN len;
3248 junk = SvPV_force(sv, tlen);
3250 SvGROW(sv, tlen + len + 1);
3253 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3255 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3260 =for apidoc sv_catpv_mg
3262 Like C<sv_catpv>, but also handles 'set' magic.
3268 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3275 Perl_newSV(pTHX_ STRLEN len)
3281 sv_upgrade(sv, SVt_PV);
3282 SvGROW(sv, len + 1);
3287 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3290 =for apidoc sv_magic
3292 Adds magic to an SV.
3298 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3302 if (SvREADONLY(sv)) {
3304 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3305 Perl_croak(aTHX_ PL_no_modify);
3307 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3308 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3315 (void)SvUPGRADE(sv, SVt_PVMG);
3317 Newz(702,mg, 1, MAGIC);
3318 mg->mg_moremagic = SvMAGIC(sv);
3321 if (!obj || obj == sv || how == '#' || how == 'r')
3325 mg->mg_obj = SvREFCNT_inc(obj);
3326 mg->mg_flags |= MGf_REFCOUNTED;
3329 mg->mg_len = namlen;
3332 mg->mg_ptr = savepvn(name, namlen);
3333 else if (namlen == HEf_SVKEY)
3334 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3338 mg->mg_virtual = &PL_vtbl_sv;
3341 mg->mg_virtual = &PL_vtbl_amagic;
3344 mg->mg_virtual = &PL_vtbl_amagicelem;
3350 mg->mg_virtual = &PL_vtbl_bm;
3353 mg->mg_virtual = &PL_vtbl_regdata;
3356 mg->mg_virtual = &PL_vtbl_regdatum;
3359 mg->mg_virtual = &PL_vtbl_env;
3362 mg->mg_virtual = &PL_vtbl_fm;
3365 mg->mg_virtual = &PL_vtbl_envelem;
3368 mg->mg_virtual = &PL_vtbl_mglob;
3371 mg->mg_virtual = &PL_vtbl_isa;
3374 mg->mg_virtual = &PL_vtbl_isaelem;
3377 mg->mg_virtual = &PL_vtbl_nkeys;
3384 mg->mg_virtual = &PL_vtbl_dbline;
3388 mg->mg_virtual = &PL_vtbl_mutex;
3390 #endif /* USE_THREADS */
3391 #ifdef USE_LOCALE_COLLATE
3393 mg->mg_virtual = &PL_vtbl_collxfrm;
3395 #endif /* USE_LOCALE_COLLATE */
3397 mg->mg_virtual = &PL_vtbl_pack;
3401 mg->mg_virtual = &PL_vtbl_packelem;
3404 mg->mg_virtual = &PL_vtbl_regexp;
3407 mg->mg_virtual = &PL_vtbl_sig;
3410 mg->mg_virtual = &PL_vtbl_sigelem;
3413 mg->mg_virtual = &PL_vtbl_taint;
3417 mg->mg_virtual = &PL_vtbl_uvar;
3420 mg->mg_virtual = &PL_vtbl_vec;
3423 mg->mg_virtual = &PL_vtbl_substr;
3426 mg->mg_virtual = &PL_vtbl_defelem;
3429 mg->mg_virtual = &PL_vtbl_glob;
3432 mg->mg_virtual = &PL_vtbl_arylen;
3435 mg->mg_virtual = &PL_vtbl_pos;
3438 mg->mg_virtual = &PL_vtbl_backref;
3440 case '~': /* Reserved for use by extensions not perl internals. */
3441 /* Useful for attaching extension internal data to perl vars. */
3442 /* Note that multiple extensions may clash if magical scalars */
3443 /* etc holding private data from one are passed to another. */
3447 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3451 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3455 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3459 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3462 for (mg = *mgp; mg; mg = *mgp) {
3463 if (mg->mg_type == type) {
3464 MGVTBL* vtbl = mg->mg_virtual;
3465 *mgp = mg->mg_moremagic;
3466 if (vtbl && vtbl->svt_free)
3467 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3468 if (mg->mg_ptr && mg->mg_type != 'g')
3469 if (mg->mg_len >= 0)
3470 Safefree(mg->mg_ptr);
3471 else if (mg->mg_len == HEf_SVKEY)
3472 SvREFCNT_dec((SV*)mg->mg_ptr);
3473 if (mg->mg_flags & MGf_REFCOUNTED)
3474 SvREFCNT_dec(mg->mg_obj);
3478 mgp = &mg->mg_moremagic;
3482 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3489 Perl_sv_rvweaken(pTHX_ SV *sv)
3492 if (!SvOK(sv)) /* let undefs pass */
3495 Perl_croak(aTHX_ "Can't weaken a nonreference");
3496 else if (SvWEAKREF(sv)) {
3498 if (ckWARN(WARN_MISC))
3499 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3503 sv_add_backref(tsv, sv);
3510 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3514 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3515 av = (AV*)mg->mg_obj;
3518 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3519 SvREFCNT_dec(av); /* for sv_magic */
3525 S_sv_del_backref(pTHX_ SV *sv)
3532 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3533 Perl_croak(aTHX_ "panic: del_backref");
3534 av = (AV *)mg->mg_obj;
3539 svp[i] = &PL_sv_undef; /* XXX */
3546 =for apidoc sv_insert
3548 Inserts a string at the specified offset/length within the SV. Similar to
3549 the Perl substr() function.
3555 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3559 register char *midend;
3560 register char *bigend;
3566 Perl_croak(aTHX_ "Can't modify non-existent substring");
3567 SvPV_force(bigstr, curlen);
3568 (void)SvPOK_only_UTF8(bigstr);
3569 if (offset + len > curlen) {
3570 SvGROW(bigstr, offset+len+1);
3571 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3572 SvCUR_set(bigstr, offset+len);
3576 i = littlelen - len;
3577 if (i > 0) { /* string might grow */
3578 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3579 mid = big + offset + len;
3580 midend = bigend = big + SvCUR(bigstr);
3583 while (midend > mid) /* shove everything down */
3584 *--bigend = *--midend;
3585 Move(little,big+offset,littlelen,char);
3591 Move(little,SvPVX(bigstr)+offset,len,char);
3596 big = SvPVX(bigstr);
3599 bigend = big + SvCUR(bigstr);
3601 if (midend > bigend)
3602 Perl_croak(aTHX_ "panic: sv_insert");
3604 if (mid - big > bigend - midend) { /* faster to shorten from end */
3606 Move(little, mid, littlelen,char);
3609 i = bigend - midend;
3611 Move(midend, mid, i,char);
3615 SvCUR_set(bigstr, mid - big);
3618 else if ((i = mid - big)) { /* faster from front */
3619 midend -= littlelen;
3621 sv_chop(bigstr,midend-i);
3626 Move(little, mid, littlelen,char);
3628 else if (littlelen) {
3629 midend -= littlelen;
3630 sv_chop(bigstr,midend);
3631 Move(little,midend,littlelen,char);
3634 sv_chop(bigstr,midend);
3639 /* make sv point to what nstr did */
3642 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3645 U32 refcnt = SvREFCNT(sv);
3646 SV_CHECK_THINKFIRST(sv);
3647 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3648 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3649 if (SvMAGICAL(sv)) {
3653 sv_upgrade(nsv, SVt_PVMG);
3654 SvMAGIC(nsv) = SvMAGIC(sv);
3655 SvFLAGS(nsv) |= SvMAGICAL(sv);
3661 assert(!SvREFCNT(sv));
3662 StructCopy(nsv,sv,SV);
3663 SvREFCNT(sv) = refcnt;
3664 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3669 Perl_sv_clear(pTHX_ register SV *sv)
3673 assert(SvREFCNT(sv) == 0);
3677 if (PL_defstash) { /* Still have a symbol table? */
3682 Zero(&tmpref, 1, SV);
3683 sv_upgrade(&tmpref, SVt_RV);
3685 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3686 SvREFCNT(&tmpref) = 1;
3689 stash = SvSTASH(sv);
3690 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3693 PUSHSTACKi(PERLSI_DESTROY);
3694 SvRV(&tmpref) = SvREFCNT_inc(sv);
3699 call_sv((SV*)GvCV(destructor),
3700 G_DISCARD|G_EVAL|G_KEEPERR);
3706 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3708 del_XRV(SvANY(&tmpref));
3711 if (PL_in_clean_objs)
3712 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3714 /* DESTROY gave object new lease on life */
3720 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3721 SvOBJECT_off(sv); /* Curse the object. */
3722 if (SvTYPE(sv) != SVt_PVIO)
3723 --PL_sv_objcount; /* XXX Might want something more general */
3726 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3729 switch (SvTYPE(sv)) {
3732 IoIFP(sv) != PerlIO_stdin() &&
3733 IoIFP(sv) != PerlIO_stdout() &&
3734 IoIFP(sv) != PerlIO_stderr())
3736 io_close((IO*)sv, FALSE);
3738 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3739 PerlDir_close(IoDIRP(sv));
3740 IoDIRP(sv) = (DIR*)NULL;
3741 Safefree(IoTOP_NAME(sv));
3742 Safefree(IoFMT_NAME(sv));
3743 Safefree(IoBOTTOM_NAME(sv));
3758 SvREFCNT_dec(LvTARG(sv));
3762 Safefree(GvNAME(sv));
3763 /* cannot decrease stash refcount yet, as we might recursively delete
3764 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3765 of stash until current sv is completely gone.
3766 -- JohnPC, 27 Mar 1998 */
3767 stash = GvSTASH(sv);
3773 (void)SvOOK_off(sv);
3781 SvREFCNT_dec(SvRV(sv));
3783 else if (SvPVX(sv) && SvLEN(sv))
3784 Safefree(SvPVX(sv));
3794 switch (SvTYPE(sv)) {
3810 del_XPVIV(SvANY(sv));
3813 del_XPVNV(SvANY(sv));
3816 del_XPVMG(SvANY(sv));
3819 del_XPVLV(SvANY(sv));
3822 del_XPVAV(SvANY(sv));
3825 del_XPVHV(SvANY(sv));
3828 del_XPVCV(SvANY(sv));
3831 del_XPVGV(SvANY(sv));
3832 /* code duplication for increased performance. */
3833 SvFLAGS(sv) &= SVf_BREAK;
3834 SvFLAGS(sv) |= SVTYPEMASK;
3835 /* decrease refcount of the stash that owns this GV, if any */
3837 SvREFCNT_dec(stash);
3838 return; /* not break, SvFLAGS reset already happened */
3840 del_XPVBM(SvANY(sv));
3843 del_XPVFM(SvANY(sv));
3846 del_XPVIO(SvANY(sv));
3849 SvFLAGS(sv) &= SVf_BREAK;
3850 SvFLAGS(sv) |= SVTYPEMASK;
3854 Perl_sv_newref(pTHX_ SV *sv)
3857 ATOMIC_INC(SvREFCNT(sv));
3862 Perl_sv_free(pTHX_ SV *sv)
3865 int refcount_is_zero;
3869 if (SvREFCNT(sv) == 0) {
3870 if (SvFLAGS(sv) & SVf_BREAK)
3872 if (PL_in_clean_all) /* All is fair */
3874 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3875 /* make sure SvREFCNT(sv)==0 happens very seldom */
3876 SvREFCNT(sv) = (~(U32)0)/2;
3879 if (ckWARN_d(WARN_INTERNAL))
3880 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3883 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3884 if (!refcount_is_zero)
3888 if (ckWARN_d(WARN_DEBUGGING))
3889 Perl_warner(aTHX_ WARN_DEBUGGING,
3890 "Attempt to free temp prematurely: SV 0x%"UVxf,
3895 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3896 /* make sure SvREFCNT(sv)==0 happens very seldom */
3897 SvREFCNT(sv) = (~(U32)0)/2;
3908 Returns the length of the string in the SV. See also C<SvCUR>.
3914 Perl_sv_len(pTHX_ register SV *sv)
3923 len = mg_length(sv);
3925 junk = SvPV(sv, len);
3930 Perl_sv_len_utf8(pTHX_ register SV *sv)
3941 len = mg_length(sv);
3944 s = (U8*)SvPV(sv, len);
3955 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
3960 I32 uoffset = *offsetp;
3966 start = s = (U8*)SvPV(sv, len);
3968 while (s < send && uoffset--)
3972 *offsetp = s - start;
3976 while (s < send && ulen--)
3986 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
3995 s = (U8*)SvPV(sv, len);
3997 Perl_croak(aTHX_ "panic: bad byte offset");
3998 send = s + *offsetp;
4006 if (ckWARN_d(WARN_UTF8))
4007 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4017 Returns a boolean indicating whether the strings in the two SVs are
4024 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
4036 pv1 = SvPV(str1, cur1);
4041 if (SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
4043 sv_utf8_upgrade(str2);
4046 sv_utf8_upgrade(str1);
4050 pv2 = SvPV(str2, cur2);
4055 return memEQ(pv1, pv2, cur1);
4061 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4062 string in C<sv1> is less than, equal to, or greater than the string in
4069 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
4076 pv1 = SvPV(str1, cur1);
4084 if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
4085 /* must upgrade other to UTF8 first */
4087 sv_utf8_upgrade(str2);
4090 sv_utf8_upgrade(str1);
4091 /* refresh pointer and length */
4100 pv2 = sv_2pv(str2, &cur2);
4108 return cur2 ? -1 : 0;
4113 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4116 return retval < 0 ? -1 : 1;
4121 return cur1 < cur2 ? -1 : 1;
4125 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4127 #ifdef USE_LOCALE_COLLATE
4133 if (PL_collation_standard)
4137 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4139 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4141 if (!pv1 || !len1) {
4152 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4155 return retval < 0 ? -1 : 1;
4158 * When the result of collation is equality, that doesn't mean
4159 * that there are no differences -- some locales exclude some
4160 * characters from consideration. So to avoid false equalities,
4161 * we use the raw string as a tiebreaker.
4167 #endif /* USE_LOCALE_COLLATE */
4169 return sv_cmp(sv1, sv2);
4172 #ifdef USE_LOCALE_COLLATE
4174 * Any scalar variable may carry an 'o' magic that contains the
4175 * scalar data of the variable transformed to such a format that
4176 * a normal memory comparison can be used to compare the data
4177 * according to the locale settings.
4180 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4184 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4185 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4190 Safefree(mg->mg_ptr);
4192 if ((xf = mem_collxfrm(s, len, &xlen))) {
4193 if (SvREADONLY(sv)) {
4196 return xf + sizeof(PL_collation_ix);
4199 sv_magic(sv, 0, 'o', 0, 0);
4200 mg = mg_find(sv, 'o');
4213 if (mg && mg->mg_ptr) {
4215 return mg->mg_ptr + sizeof(PL_collation_ix);
4223 #endif /* USE_LOCALE_COLLATE */
4226 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4231 register STDCHAR rslast;
4232 register STDCHAR *bp;
4236 SV_CHECK_THINKFIRST(sv);
4237 (void)SvUPGRADE(sv, SVt_PV);
4241 if (RsSNARF(PL_rs)) {
4245 else if (RsRECORD(PL_rs)) {
4246 I32 recsize, bytesread;
4249 /* Grab the size of the record we're getting */
4250 recsize = SvIV(SvRV(PL_rs));
4251 (void)SvPOK_only(sv); /* Validate pointer */
4252 buffer = SvGROW(sv, recsize + 1);
4255 /* VMS wants read instead of fread, because fread doesn't respect */
4256 /* RMS record boundaries. This is not necessarily a good thing to be */
4257 /* doing, but we've got no other real choice */
4258 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4260 bytesread = PerlIO_read(fp, buffer, recsize);
4262 SvCUR_set(sv, bytesread);
4263 buffer[bytesread] = '\0';
4264 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4266 else if (RsPARA(PL_rs)) {
4271 rsptr = SvPV(PL_rs, rslen);
4272 rslast = rslen ? rsptr[rslen - 1] : '\0';
4274 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4275 do { /* to make sure file boundaries work right */
4278 i = PerlIO_getc(fp);
4282 PerlIO_ungetc(fp,i);
4288 /* See if we know enough about I/O mechanism to cheat it ! */
4290 /* This used to be #ifdef test - it is made run-time test for ease
4291 of abstracting out stdio interface. One call should be cheap
4292 enough here - and may even be a macro allowing compile
4296 if (PerlIO_fast_gets(fp)) {
4299 * We're going to steal some values from the stdio struct
4300 * and put EVERYTHING in the innermost loop into registers.
4302 register STDCHAR *ptr;
4306 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4307 /* An ungetc()d char is handled separately from the regular
4308 * buffer, so we getc() it back out and stuff it in the buffer.
4310 i = PerlIO_getc(fp);
4311 if (i == EOF) return 0;
4312 *(--((*fp)->_ptr)) = (unsigned char) i;
4316 /* Here is some breathtakingly efficient cheating */
4318 cnt = PerlIO_get_cnt(fp); /* get count into register */
4319 (void)SvPOK_only(sv); /* validate pointer */
4320 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4321 if (cnt > 80 && SvLEN(sv) > append) {
4322 shortbuffered = cnt - SvLEN(sv) + append + 1;
4323 cnt -= shortbuffered;
4327 /* remember that cnt can be negative */
4328 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4333 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4334 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4335 DEBUG_P(PerlIO_printf(Perl_debug_log,
4336 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4337 DEBUG_P(PerlIO_printf(Perl_debug_log,
4338 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4339 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4340 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4345 while (cnt > 0) { /* this | eat */
4347 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4348 goto thats_all_folks; /* screams | sed :-) */
4352 Copy(ptr, bp, cnt, char); /* this | eat */
4353 bp += cnt; /* screams | dust */
4354 ptr += cnt; /* louder | sed :-) */
4359 if (shortbuffered) { /* oh well, must extend */
4360 cnt = shortbuffered;
4362 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4364 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4365 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4369 DEBUG_P(PerlIO_printf(Perl_debug_log,
4370 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4371 PTR2UV(ptr),(long)cnt));
4372 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4373 DEBUG_P(PerlIO_printf(Perl_debug_log,
4374 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4375 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4376 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4377 /* This used to call 'filbuf' in stdio form, but as that behaves like
4378 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4379 another abstraction. */
4380 i = PerlIO_getc(fp); /* get more characters */
4381 DEBUG_P(PerlIO_printf(Perl_debug_log,
4382 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4383 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4384 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4385 cnt = PerlIO_get_cnt(fp);
4386 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4387 DEBUG_P(PerlIO_printf(Perl_debug_log,
4388 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4390 if (i == EOF) /* all done for ever? */
4391 goto thats_really_all_folks;
4393 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4395 SvGROW(sv, bpx + cnt + 2);
4396 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4398 *bp++ = i; /* store character from PerlIO_getc */
4400 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4401 goto thats_all_folks;
4405 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4406 memNE((char*)bp - rslen, rsptr, rslen))
4407 goto screamer; /* go back to the fray */
4408 thats_really_all_folks:
4410 cnt += shortbuffered;
4411 DEBUG_P(PerlIO_printf(Perl_debug_log,
4412 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4413 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4414 DEBUG_P(PerlIO_printf(Perl_debug_log,
4415 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4416 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4417 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4419 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4420 DEBUG_P(PerlIO_printf(Perl_debug_log,
4421 "Screamer: done, len=%ld, string=|%.*s|\n",
4422 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4427 /*The big, slow, and stupid way */
4430 /* Need to work around EPOC SDK features */
4431 /* On WINS: MS VC5 generates calls to _chkstk, */
4432 /* if a `large' stack frame is allocated */
4433 /* gcc on MARM does not generate calls like these */
4439 register STDCHAR *bpe = buf + sizeof(buf);
4441 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4442 ; /* keep reading */
4446 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4447 /* Accomodate broken VAXC compiler, which applies U8 cast to
4448 * both args of ?: operator, causing EOF to change into 255
4450 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4454 sv_catpvn(sv, (char *) buf, cnt);
4456 sv_setpvn(sv, (char *) buf, cnt);
4458 if (i != EOF && /* joy */
4460 SvCUR(sv) < rslen ||
4461 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4465 * If we're reading from a TTY and we get a short read,
4466 * indicating that the user hit his EOF character, we need
4467 * to notice it now, because if we try to read from the TTY
4468 * again, the EOF condition will disappear.
4470 * The comparison of cnt to sizeof(buf) is an optimization
4471 * that prevents unnecessary calls to feof().
4475 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4480 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4481 while (i != EOF) { /* to make sure file boundaries work right */
4482 i = PerlIO_getc(fp);
4484 PerlIO_ungetc(fp,i);
4490 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4497 Auto-increment of the value in the SV.
4503 Perl_sv_inc(pTHX_ register SV *sv)
4512 if (SvTHINKFIRST(sv)) {
4513 if (SvREADONLY(sv)) {
4515 if (PL_curcop != &PL_compiling)
4516 Perl_croak(aTHX_ PL_no_modify);
4520 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4522 i = PTR2IV(SvRV(sv));
4527 flags = SvFLAGS(sv);
4528 if (flags & SVp_NOK) {
4529 (void)SvNOK_only(sv);
4533 if (flags & SVp_IOK) {
4535 if (SvUVX(sv) == UV_MAX)
4536 sv_setnv(sv, (NV)UV_MAX + 1.0);
4538 (void)SvIOK_only_UV(sv);
4541 if (SvIVX(sv) == IV_MAX)
4542 sv_setnv(sv, (NV)IV_MAX + 1.0);
4544 (void)SvIOK_only(sv);
4550 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4551 if ((flags & SVTYPEMASK) < SVt_PVNV)
4552 sv_upgrade(sv, SVt_NV);
4554 (void)SvNOK_only(sv);
4558 while (isALPHA(*d)) d++;
4559 while (isDIGIT(*d)) d++;
4561 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4565 while (d >= SvPVX(sv)) {
4573 /* MKS: The original code here died if letters weren't consecutive.
4574 * at least it didn't have to worry about non-C locales. The
4575 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4576 * arranged in order (although not consecutively) and that only
4577 * [A-Za-z] are accepted by isALPHA in the C locale.
4579 if (*d != 'z' && *d != 'Z') {
4580 do { ++*d; } while (!isALPHA(*d));
4583 *(d--) -= 'z' - 'a';
4588 *(d--) -= 'z' - 'a' + 1;
4592 /* oh,oh, the number grew */
4593 SvGROW(sv, SvCUR(sv) + 2);
4595 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4606 Auto-decrement of the value in the SV.
4612 Perl_sv_dec(pTHX_ register SV *sv)
4620 if (SvTHINKFIRST(sv)) {
4621 if (SvREADONLY(sv)) {
4623 if (PL_curcop != &PL_compiling)
4624 Perl_croak(aTHX_ PL_no_modify);
4628 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4630 i = PTR2IV(SvRV(sv));
4635 flags = SvFLAGS(sv);
4636 if (flags & SVp_NOK) {
4638 (void)SvNOK_only(sv);
4641 if (flags & SVp_IOK) {
4643 if (SvUVX(sv) == 0) {
4644 (void)SvIOK_only(sv);
4648 (void)SvIOK_only_UV(sv);
4652 if (SvIVX(sv) == IV_MIN)
4653 sv_setnv(sv, (NV)IV_MIN - 1.0);
4655 (void)SvIOK_only(sv);
4661 if (!(flags & SVp_POK)) {
4662 if ((flags & SVTYPEMASK) < SVt_PVNV)
4663 sv_upgrade(sv, SVt_NV);
4665 (void)SvNOK_only(sv);
4668 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4672 =for apidoc sv_mortalcopy
4674 Creates a new SV which is a copy of the original SV. The new SV is marked
4680 /* Make a string that will exist for the duration of the expression
4681 * evaluation. Actually, it may have to last longer than that, but
4682 * hopefully we won't free it until it has been assigned to a
4683 * permanent location. */
4686 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4692 sv_setsv(sv,oldstr);
4694 PL_tmps_stack[++PL_tmps_ix] = sv;
4700 =for apidoc sv_newmortal
4702 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4708 Perl_sv_newmortal(pTHX)
4714 SvFLAGS(sv) = SVs_TEMP;
4716 PL_tmps_stack[++PL_tmps_ix] = sv;
4721 =for apidoc sv_2mortal
4723 Marks an SV as mortal. The SV will be destroyed when the current context
4729 /* same thing without the copying */
4732 Perl_sv_2mortal(pTHX_ register SV *sv)
4737 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4740 PL_tmps_stack[++PL_tmps_ix] = sv;
4748 Creates a new SV and copies a string into it. The reference count for the
4749 SV is set to 1. If C<len> is zero, Perl will compute the length using
4750 strlen(). For efficiency, consider using C<newSVpvn> instead.
4756 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4763 sv_setpvn(sv,s,len);
4768 =for apidoc newSVpvn
4770 Creates a new SV and copies a string into it. The reference count for the
4771 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4772 string. You are responsible for ensuring that the source string is at least
4779 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4784 sv_setpvn(sv,s,len);
4788 #if defined(PERL_IMPLICIT_CONTEXT)
4790 Perl_newSVpvf_nocontext(const char* pat, ...)
4795 va_start(args, pat);
4796 sv = vnewSVpvf(pat, &args);
4803 =for apidoc newSVpvf
4805 Creates a new SV an initialize it with the string formatted like
4812 Perl_newSVpvf(pTHX_ const char* pat, ...)
4816 va_start(args, pat);
4817 sv = vnewSVpvf(pat, &args);
4823 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4827 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4834 Creates a new SV and copies a floating point value into it.
4835 The reference count for the SV is set to 1.
4841 Perl_newSVnv(pTHX_ NV n)
4853 Creates a new SV and copies an integer into it. The reference count for the
4860 Perl_newSViv(pTHX_ IV i)
4872 Creates a new SV and copies an unsigned integer into it.
4873 The reference count for the SV is set to 1.
4879 Perl_newSVuv(pTHX_ UV u)
4889 =for apidoc newRV_noinc
4891 Creates an RV wrapper for an SV. The reference count for the original
4892 SV is B<not> incremented.
4898 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4904 sv_upgrade(sv, SVt_RV);
4911 /* newRV_inc is #defined to newRV in sv.h */
4913 Perl_newRV(pTHX_ SV *tmpRef)
4915 return newRV_noinc(SvREFCNT_inc(tmpRef));
4921 Creates a new SV which is an exact duplicate of the original SV.
4926 /* make an exact duplicate of old */
4929 Perl_newSVsv(pTHX_ register SV *old)
4936 if (SvTYPE(old) == SVTYPEMASK) {
4937 if (ckWARN_d(WARN_INTERNAL))
4938 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
4953 Perl_sv_reset(pTHX_ register char *s, HV *stash)
4961 char todo[PERL_UCHAR_MAX+1];
4966 if (!*s) { /* reset ?? searches */
4967 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
4968 pm->op_pmdynflags &= ~PMdf_USED;
4973 /* reset variables */
4975 if (!HvARRAY(stash))
4978 Zero(todo, 256, char);
4980 i = (unsigned char)*s;
4984 max = (unsigned char)*s++;
4985 for ( ; i <= max; i++) {
4988 for (i = 0; i <= (I32) HvMAX(stash); i++) {
4989 for (entry = HvARRAY(stash)[i];
4991 entry = HeNEXT(entry))
4993 if (!todo[(U8)*HeKEY(entry)])
4995 gv = (GV*)HeVAL(entry);
4997 if (SvTHINKFIRST(sv)) {
4998 if (!SvREADONLY(sv) && SvROK(sv))
5003 if (SvTYPE(sv) >= SVt_PV) {
5005 if (SvPVX(sv) != Nullch)
5012 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5014 #ifndef VMS /* VMS has no environ array */
5016 environ[0] = Nullch;
5025 Perl_sv_2io(pTHX_ SV *sv)
5031 switch (SvTYPE(sv)) {
5039 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5043 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5045 return sv_2io(SvRV(sv));
5046 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5052 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5059 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5066 return *gvp = Nullgv, Nullcv;
5067 switch (SvTYPE(sv)) {
5087 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5088 tryAMAGICunDEREF(to_cv);
5091 if (SvTYPE(sv) == SVt_PVCV) {
5100 Perl_croak(aTHX_ "Not a subroutine reference");
5105 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5111 if (lref && !GvCVu(gv)) {
5114 tmpsv = NEWSV(704,0);
5115 gv_efullname3(tmpsv, gv, Nullch);
5116 /* XXX this is probably not what they think they're getting.
5117 * It has the same effect as "sub name;", i.e. just a forward
5119 newSUB(start_subparse(FALSE, 0),
5120 newSVOP(OP_CONST, 0, tmpsv),
5125 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5132 Perl_sv_true(pTHX_ register SV *sv)
5139 if ((tXpv = (XPV*)SvANY(sv)) &&
5140 (tXpv->xpv_cur > 1 ||
5141 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5148 return SvIVX(sv) != 0;
5151 return SvNVX(sv) != 0.0;
5153 return sv_2bool(sv);
5159 Perl_sv_iv(pTHX_ register SV *sv)
5163 return (IV)SvUVX(sv);
5170 Perl_sv_uv(pTHX_ register SV *sv)
5175 return (UV)SvIVX(sv);
5181 Perl_sv_nv(pTHX_ register SV *sv)
5189 Perl_sv_pv(pTHX_ SV *sv)
5196 return sv_2pv(sv, &n_a);
5200 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5206 return sv_2pv(sv, lp);
5210 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5214 if (SvTHINKFIRST(sv) && !SvROK(sv))
5215 sv_force_normal(sv);
5221 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5223 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5224 PL_op_name[PL_op->op_type]);
5228 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5233 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5234 SvGROW(sv, len + 1);
5235 Move(s,SvPVX(sv),len,char);
5240 SvPOK_on(sv); /* validate pointer */
5242 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5243 PTR2UV(sv),SvPVX(sv)));
5250 Perl_sv_pvbyte(pTHX_ SV *sv)
5256 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5258 return sv_pvn(sv,lp);
5262 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5264 return sv_pvn_force(sv,lp);
5268 Perl_sv_pvutf8(pTHX_ SV *sv)
5270 sv_utf8_upgrade(sv);
5275 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5277 sv_utf8_upgrade(sv);
5278 return sv_pvn(sv,lp);
5282 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5284 sv_utf8_upgrade(sv);
5285 return sv_pvn_force(sv,lp);
5289 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5291 if (ob && SvOBJECT(sv))
5292 return HvNAME(SvSTASH(sv));
5294 switch (SvTYPE(sv)) {
5308 case SVt_PVLV: return "LVALUE";
5309 case SVt_PVAV: return "ARRAY";
5310 case SVt_PVHV: return "HASH";
5311 case SVt_PVCV: return "CODE";
5312 case SVt_PVGV: return "GLOB";
5313 case SVt_PVFM: return "FORMAT";
5314 case SVt_PVIO: return "IO";
5315 default: return "UNKNOWN";
5321 =for apidoc sv_isobject
5323 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5324 object. If the SV is not an RV, or if the object is not blessed, then this
5331 Perl_sv_isobject(pTHX_ SV *sv)
5348 Returns a boolean indicating whether the SV is blessed into the specified
5349 class. This does not check for subtypes; use C<sv_derived_from> to verify
5350 an inheritance relationship.
5356 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5368 return strEQ(HvNAME(SvSTASH(sv)), name);
5374 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5375 it will be upgraded to one. If C<classname> is non-null then the new SV will
5376 be blessed in the specified package. The new SV is returned and its
5377 reference count is 1.
5383 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5390 SV_CHECK_THINKFIRST(rv);
5393 if (SvTYPE(rv) < SVt_RV)
5394 sv_upgrade(rv, SVt_RV);
5401 HV* stash = gv_stashpv(classname, TRUE);
5402 (void)sv_bless(rv, stash);
5408 =for apidoc sv_setref_pv
5410 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5411 argument will be upgraded to an RV. That RV will be modified to point to
5412 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5413 into the SV. The C<classname> argument indicates the package for the
5414 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5415 will be returned and will have a reference count of 1.
5417 Do not use with other Perl types such as HV, AV, SV, CV, because those
5418 objects will become corrupted by the pointer copy process.
5420 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5426 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5429 sv_setsv(rv, &PL_sv_undef);
5433 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5438 =for apidoc sv_setref_iv
5440 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5441 argument will be upgraded to an RV. That RV will be modified to point to
5442 the new SV. The C<classname> argument indicates the package for the
5443 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5444 will be returned and will have a reference count of 1.
5450 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5452 sv_setiv(newSVrv(rv,classname), iv);
5457 =for apidoc sv_setref_nv
5459 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5460 argument will be upgraded to an RV. That RV will be modified to point to
5461 the new SV. The C<classname> argument indicates the package for the
5462 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5463 will be returned and will have a reference count of 1.
5469 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5471 sv_setnv(newSVrv(rv,classname), nv);
5476 =for apidoc sv_setref_pvn
5478 Copies a string into a new SV, optionally blessing the SV. The length of the
5479 string must be specified with C<n>. The C<rv> argument will be upgraded to
5480 an RV. That RV will be modified to point to the new SV. The C<classname>
5481 argument indicates the package for the blessing. Set C<classname> to
5482 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5483 a reference count of 1.
5485 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5491 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5493 sv_setpvn(newSVrv(rv,classname), pv, n);
5498 =for apidoc sv_bless
5500 Blesses an SV into a specified package. The SV must be an RV. The package
5501 must be designated by its stash (see C<gv_stashpv()>). The reference count
5502 of the SV is unaffected.
5508 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5513 Perl_croak(aTHX_ "Can't bless non-reference value");
5515 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5516 if (SvREADONLY(tmpRef))
5517 Perl_croak(aTHX_ PL_no_modify);
5518 if (SvOBJECT(tmpRef)) {
5519 if (SvTYPE(tmpRef) != SVt_PVIO)
5521 SvREFCNT_dec(SvSTASH(tmpRef));
5524 SvOBJECT_on(tmpRef);
5525 if (SvTYPE(tmpRef) != SVt_PVIO)
5527 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5528 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5539 S_sv_unglob(pTHX_ SV *sv)
5543 assert(SvTYPE(sv) == SVt_PVGV);
5548 SvREFCNT_dec(GvSTASH(sv));
5549 GvSTASH(sv) = Nullhv;
5551 sv_unmagic(sv, '*');
5552 Safefree(GvNAME(sv));
5555 /* need to keep SvANY(sv) in the right arena */
5556 xpvmg = new_XPVMG();
5557 StructCopy(SvANY(sv), xpvmg, XPVMG);
5558 del_XPVGV(SvANY(sv));
5561 SvFLAGS(sv) &= ~SVTYPEMASK;
5562 SvFLAGS(sv) |= SVt_PVMG;
5566 =for apidoc sv_unref
5568 Unsets the RV status of the SV, and decrements the reference count of
5569 whatever was being referenced by the RV. This can almost be thought of
5570 as a reversal of C<newSVrv>. See C<SvROK_off>.
5576 Perl_sv_unref(pTHX_ SV *sv)
5580 if (SvWEAKREF(sv)) {
5588 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5591 sv_2mortal(rv); /* Schedule for freeing later */
5595 Perl_sv_taint(pTHX_ SV *sv)
5597 sv_magic((sv), Nullsv, 't', Nullch, 0);
5601 Perl_sv_untaint(pTHX_ SV *sv)
5603 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5604 MAGIC *mg = mg_find(sv, 't');
5611 Perl_sv_tainted(pTHX_ SV *sv)
5613 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5614 MAGIC *mg = mg_find(sv, 't');
5615 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5622 =for apidoc sv_setpviv
5624 Copies an integer into the given SV, also updating its string value.
5625 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5631 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5633 char buf[TYPE_CHARS(UV)];
5635 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5637 sv_setpvn(sv, ptr, ebuf - ptr);
5642 =for apidoc sv_setpviv_mg
5644 Like C<sv_setpviv>, but also handles 'set' magic.
5650 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5652 char buf[TYPE_CHARS(UV)];
5654 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5656 sv_setpvn(sv, ptr, ebuf - ptr);
5660 #if defined(PERL_IMPLICIT_CONTEXT)
5662 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5666 va_start(args, pat);
5667 sv_vsetpvf(sv, pat, &args);
5673 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5677 va_start(args, pat);
5678 sv_vsetpvf_mg(sv, pat, &args);
5684 =for apidoc sv_setpvf
5686 Processes its arguments like C<sprintf> and sets an SV to the formatted
5687 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5693 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5696 va_start(args, pat);
5697 sv_vsetpvf(sv, pat, &args);
5702 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5704 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5708 =for apidoc sv_setpvf_mg
5710 Like C<sv_setpvf>, but also handles 'set' magic.
5716 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5719 va_start(args, pat);
5720 sv_vsetpvf_mg(sv, pat, &args);
5725 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5727 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5731 #if defined(PERL_IMPLICIT_CONTEXT)
5733 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5737 va_start(args, pat);
5738 sv_vcatpvf(sv, pat, &args);
5743 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5747 va_start(args, pat);
5748 sv_vcatpvf_mg(sv, pat, &args);
5754 =for apidoc sv_catpvf
5756 Processes its arguments like C<sprintf> and appends the formatted output
5757 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5758 typically be called after calling this function to handle 'set' magic.
5764 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5767 va_start(args, pat);
5768 sv_vcatpvf(sv, pat, &args);
5773 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5775 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5779 =for apidoc sv_catpvf_mg
5781 Like C<sv_catpvf>, but also handles 'set' magic.
5787 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5790 va_start(args, pat);
5791 sv_vcatpvf_mg(sv, pat, &args);
5796 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5798 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5803 =for apidoc sv_vsetpvfn
5805 Works like C<vcatpvfn> but copies the text into the SV instead of
5812 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5814 sv_setpvn(sv, "", 0);
5815 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5819 =for apidoc sv_vcatpvfn
5821 Processes its arguments like C<vsprintf> and appends the formatted output
5822 to an SV. Uses an array of SVs if the C style variable argument list is
5823 missing (NULL). When running with taint checks enabled, indicates via
5824 C<maybe_tainted> if results are untrustworthy (often due to the use of
5831 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5839 static char nullstr[] = "(null)";
5842 /* no matter what, this is a string now */
5843 (void)SvPV_force(sv, origlen);
5845 /* special-case "", "%s", and "%_" */
5848 if (patlen == 2 && pat[0] == '%') {
5852 char *s = va_arg(*args, char*);
5853 sv_catpv(sv, s ? s : nullstr);
5855 else if (svix < svmax) {
5856 sv_catsv(sv, *svargs);
5857 if (DO_UTF8(*svargs))
5863 argsv = va_arg(*args, SV*);
5864 sv_catsv(sv, argsv);
5869 /* See comment on '_' below */
5874 patend = (char*)pat + patlen;
5875 for (p = (char*)pat; p < patend; p = q) {
5878 bool vectorize = FALSE;
5885 bool has_precis = FALSE;
5887 bool is_utf = FALSE;
5890 U8 utf8buf[UTF8_MAXLEN];
5891 STRLEN esignlen = 0;
5893 char *eptr = Nullch;
5895 /* Times 4: a decimal digit takes more than 3 binary digits.
5896 * NV_DIG: mantissa takes than many decimal digits.
5897 * Plus 32: Playing safe. */
5898 char ebuf[IV_DIG * 4 + NV_DIG + 32];
5899 /* large enough for "%#.#f" --chip */
5900 /* what about long double NVs? --jhi */
5903 U8 *vecstr = Null(U8*);
5915 STRLEN dotstrlen = 1;
5917 for (q = p; q < patend && *q != '%'; ++q) ;
5919 sv_catpvn(sv, p, q - p);
5948 case '*': /* printf("%*vX",":",$ipv6addr) */
5953 vecsv = va_arg(*args, SV*);
5954 else if (svix < svmax)
5955 vecsv = svargs[svix++];
5958 dotstr = SvPVx(vecsv,dotstrlen);
5967 vecsv = va_arg(*args, SV*);
5968 else if (svix < svmax)
5969 vecsv = svargs[svix++];
5975 vecstr = (U8*)SvPVx(vecsv,veclen);
5976 utf = DO_UTF8(vecsv);
5988 case '1': case '2': case '3':
5989 case '4': case '5': case '6':
5990 case '7': case '8': case '9':
5993 width = width * 10 + (*q++ - '0');
5998 i = va_arg(*args, int);
6000 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6002 width = (i < 0) ? -i : i;
6013 i = va_arg(*args, int);
6015 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6016 precis = (i < 0) ? 0 : i;
6022 precis = precis * 10 + (*q++ - '0');
6039 if (*(q + 1) == 'l') { /* lld */
6066 uv = va_arg(*args, int);
6068 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6069 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6070 eptr = (char*)utf8buf;
6071 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6083 eptr = va_arg(*args, char*);
6085 #ifdef MACOS_TRADITIONAL
6086 /* On MacOS, %#s format is used for Pascal strings */
6091 elen = strlen(eptr);
6094 elen = sizeof nullstr - 1;
6097 else if (svix < svmax) {
6098 argsv = svargs[svix++];
6099 eptr = SvPVx(argsv, elen);
6100 if (DO_UTF8(argsv)) {
6101 if (has_precis && precis < elen) {
6103 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6106 if (width) { /* fudge width (can't fudge elen) */
6107 width += elen - sv_len_utf8(argsv);
6116 * The "%_" hack might have to be changed someday,
6117 * if ISO or ANSI decide to use '_' for something.
6118 * So we keep it hidden from users' code.
6122 argsv = va_arg(*args,SV*);
6123 eptr = SvPVx(argsv, elen);
6129 if (has_precis && elen > precis)
6137 uv = PTR2UV(va_arg(*args, void*));
6139 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6159 iv = (IV)utf8_to_uv(vecstr, &ulen);
6169 case 'h': iv = (short)va_arg(*args, int); break;
6170 default: iv = va_arg(*args, int); break;
6171 case 'l': iv = va_arg(*args, long); break;
6172 case 'V': iv = va_arg(*args, IV); break;
6174 case 'q': iv = va_arg(*args, Quad_t); break;
6179 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6181 case 'h': iv = (short)iv; break;
6183 case 'l': iv = (long)iv; break;
6186 case 'q': iv = (Quad_t)iv; break;
6193 esignbuf[esignlen++] = plus;
6197 esignbuf[esignlen++] = '-';
6241 uv = utf8_to_uv(vecstr, &ulen);
6251 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6252 default: uv = va_arg(*args, unsigned); break;
6253 case 'l': uv = va_arg(*args, unsigned long); break;
6254 case 'V': uv = va_arg(*args, UV); break;
6256 case 'q': uv = va_arg(*args, Quad_t); break;
6261 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6263 case 'h': uv = (unsigned short)uv; break;
6265 case 'l': uv = (unsigned long)uv; break;
6268 case 'q': uv = (Quad_t)uv; break;
6274 eptr = ebuf + sizeof ebuf;
6280 p = (char*)((c == 'X')
6281 ? "0123456789ABCDEF" : "0123456789abcdef");
6287 esignbuf[esignlen++] = '0';
6288 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6294 *--eptr = '0' + dig;
6296 if (alt && *eptr != '0')
6302 *--eptr = '0' + dig;
6305 esignbuf[esignlen++] = '0';
6306 esignbuf[esignlen++] = 'b';
6309 default: /* it had better be ten or less */
6310 #if defined(PERL_Y2KWARN)
6311 if (ckWARN(WARN_Y2K)) {
6313 char *s = SvPV(sv,n);
6314 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6315 && (n == 2 || !isDIGIT(s[n-3])))
6317 Perl_warner(aTHX_ WARN_Y2K,
6318 "Possible Y2K bug: %%%c %s",
6319 c, "format string following '19'");
6325 *--eptr = '0' + dig;
6326 } while (uv /= base);
6329 elen = (ebuf + sizeof ebuf) - eptr;
6332 zeros = precis - elen;
6333 else if (precis == 0 && elen == 1 && *eptr == '0')
6338 /* FLOATING POINT */
6341 c = 'f'; /* maybe %F isn't supported here */
6347 /* This is evil, but floating point is even more evil */
6351 nv = va_arg(*args, NV);
6353 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6356 if (c != 'e' && c != 'E') {
6358 (void)Perl_frexp(nv, &i);
6359 if (i == PERL_INT_MIN)
6360 Perl_die(aTHX_ "panic: frexp");
6362 need = BIT_DIGITS(i);
6364 need += has_precis ? precis : 6; /* known default */
6368 need += 20; /* fudge factor */
6369 if (PL_efloatsize < need) {
6370 Safefree(PL_efloatbuf);
6371 PL_efloatsize = need + 20; /* more fudge */
6372 New(906, PL_efloatbuf, PL_efloatsize, char);
6373 PL_efloatbuf[0] = '\0';
6376 eptr = ebuf + sizeof ebuf;
6379 #ifdef USE_LONG_DOUBLE
6381 static char const my_prifldbl[] = PERL_PRIfldbl;
6382 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6383 while (p >= my_prifldbl) { *--eptr = *p--; }
6388 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6393 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6406 RESTORE_NUMERIC_STANDARD();
6407 (void)sprintf(PL_efloatbuf, eptr, nv);
6408 RESTORE_NUMERIC_LOCAL();
6411 eptr = PL_efloatbuf;
6412 elen = strlen(PL_efloatbuf);
6419 i = SvCUR(sv) - origlen;
6422 case 'h': *(va_arg(*args, short*)) = i; break;
6423 default: *(va_arg(*args, int*)) = i; break;
6424 case 'l': *(va_arg(*args, long*)) = i; break;
6425 case 'V': *(va_arg(*args, IV*)) = i; break;
6427 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6431 else if (svix < svmax)
6432 sv_setuv(svargs[svix++], (UV)i);
6433 continue; /* not "break" */
6440 if (!args && ckWARN(WARN_PRINTF) &&
6441 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6442 SV *msg = sv_newmortal();
6443 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6444 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6447 Perl_sv_catpvf(aTHX_ msg,
6448 "\"%%%c\"", c & 0xFF);
6450 Perl_sv_catpvf(aTHX_ msg,
6451 "\"%%\\%03"UVof"\"",
6454 sv_catpv(msg, "end of string");
6455 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6458 /* output mangled stuff ... */
6464 /* ... right here, because formatting flags should not apply */
6465 SvGROW(sv, SvCUR(sv) + elen + 1);
6467 memcpy(p, eptr, elen);
6470 SvCUR(sv) = p - SvPVX(sv);
6471 continue; /* not "break" */
6474 have = esignlen + zeros + elen;
6475 need = (have > width ? have : width);
6478 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6480 if (esignlen && fill == '0') {
6481 for (i = 0; i < esignlen; i++)
6485 memset(p, fill, gap);
6488 if (esignlen && fill != '0') {
6489 for (i = 0; i < esignlen; i++)
6493 for (i = zeros; i; i--)
6497 memcpy(p, eptr, elen);
6501 memset(p, ' ', gap);
6506 memcpy(p, dotstr, dotstrlen);
6510 vectorize = FALSE; /* done iterating over vecstr */
6515 SvCUR(sv) = p - SvPVX(sv);
6523 #if defined(USE_ITHREADS)
6525 #if defined(USE_THREADS)
6526 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6529 #ifndef GpREFCNT_inc
6530 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6534 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6535 #define av_dup(s) (AV*)sv_dup((SV*)s)
6536 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6537 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6538 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6539 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6540 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6541 #define io_dup(s) (IO*)sv_dup((SV*)s)
6542 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6543 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6544 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6545 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6546 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6549 Perl_re_dup(pTHX_ REGEXP *r)
6551 /* XXX fix when pmop->op_pmregexp becomes shared */
6552 return ReREFCNT_inc(r);
6556 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6560 return (PerlIO*)NULL;
6562 /* look for it in the table first */
6563 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6567 /* create anew and remember what it is */
6568 ret = PerlIO_fdupopen(fp);
6569 ptr_table_store(PL_ptr_table, fp, ret);
6574 Perl_dirp_dup(pTHX_ DIR *dp)
6583 Perl_gp_dup(pTHX_ GP *gp)
6588 /* look for it in the table first */
6589 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6593 /* create anew and remember what it is */
6594 Newz(0, ret, 1, GP);
6595 ptr_table_store(PL_ptr_table, gp, ret);
6598 ret->gp_refcnt = 0; /* must be before any other dups! */
6599 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6600 ret->gp_io = io_dup_inc(gp->gp_io);
6601 ret->gp_form = cv_dup_inc(gp->gp_form);
6602 ret->gp_av = av_dup_inc(gp->gp_av);
6603 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6604 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6605 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6606 ret->gp_cvgen = gp->gp_cvgen;
6607 ret->gp_flags = gp->gp_flags;
6608 ret->gp_line = gp->gp_line;
6609 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6614 Perl_mg_dup(pTHX_ MAGIC *mg)
6616 MAGIC *mgret = (MAGIC*)NULL;
6619 return (MAGIC*)NULL;
6620 /* look for it in the table first */
6621 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6625 for (; mg; mg = mg->mg_moremagic) {
6627 Newz(0, nmg, 1, MAGIC);
6631 mgprev->mg_moremagic = nmg;
6632 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6633 nmg->mg_private = mg->mg_private;
6634 nmg->mg_type = mg->mg_type;
6635 nmg->mg_flags = mg->mg_flags;
6636 if (mg->mg_type == 'r') {
6637 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6640 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6641 ? sv_dup_inc(mg->mg_obj)
6642 : sv_dup(mg->mg_obj);
6644 nmg->mg_len = mg->mg_len;
6645 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6646 if (mg->mg_ptr && mg->mg_type != 'g') {
6647 if (mg->mg_len >= 0) {
6648 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6649 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6650 AMT *amtp = (AMT*)mg->mg_ptr;
6651 AMT *namtp = (AMT*)nmg->mg_ptr;
6653 for (i = 1; i < NofAMmeth; i++) {
6654 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6658 else if (mg->mg_len == HEf_SVKEY)
6659 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6667 Perl_ptr_table_new(pTHX)
6670 Newz(0, tbl, 1, PTR_TBL_t);
6673 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6678 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6680 PTR_TBL_ENT_t *tblent;
6681 UV hash = PTR2UV(sv);
6683 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6684 for (; tblent; tblent = tblent->next) {
6685 if (tblent->oldval == sv)
6686 return tblent->newval;
6692 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6694 PTR_TBL_ENT_t *tblent, **otblent;
6695 /* XXX this may be pessimal on platforms where pointers aren't good
6696 * hash values e.g. if they grow faster in the most significant
6698 UV hash = PTR2UV(oldv);
6702 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6703 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6704 if (tblent->oldval == oldv) {
6705 tblent->newval = newv;
6710 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6711 tblent->oldval = oldv;
6712 tblent->newval = newv;
6713 tblent->next = *otblent;
6716 if (i && tbl->tbl_items > tbl->tbl_max)
6717 ptr_table_split(tbl);
6721 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6723 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6724 UV oldsize = tbl->tbl_max + 1;
6725 UV newsize = oldsize * 2;
6728 Renew(ary, newsize, PTR_TBL_ENT_t*);
6729 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6730 tbl->tbl_max = --newsize;
6732 for (i=0; i < oldsize; i++, ary++) {
6733 PTR_TBL_ENT_t **curentp, **entp, *ent;
6736 curentp = ary + oldsize;
6737 for (entp = ary, ent = *ary; ent; ent = *entp) {
6738 if ((newsize & PTR2UV(ent->oldval)) != i) {
6740 ent->next = *curentp;
6755 Perl_sv_dup(pTHX_ SV *sstr)
6759 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6761 /* look for it in the table first */
6762 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6766 /* create anew and remember what it is */
6768 ptr_table_store(PL_ptr_table, sstr, dstr);
6771 SvFLAGS(dstr) = SvFLAGS(sstr);
6772 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6773 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6776 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6777 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6778 PL_watch_pvx, SvPVX(sstr));
6781 switch (SvTYPE(sstr)) {
6786 SvANY(dstr) = new_XIV();
6787 SvIVX(dstr) = SvIVX(sstr);
6790 SvANY(dstr) = new_XNV();
6791 SvNVX(dstr) = SvNVX(sstr);
6794 SvANY(dstr) = new_XRV();
6795 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6798 SvANY(dstr) = new_XPV();
6799 SvCUR(dstr) = SvCUR(sstr);
6800 SvLEN(dstr) = SvLEN(sstr);
6802 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6803 else if (SvPVX(sstr) && SvLEN(sstr))
6804 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6806 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6809 SvANY(dstr) = new_XPVIV();
6810 SvCUR(dstr) = SvCUR(sstr);
6811 SvLEN(dstr) = SvLEN(sstr);
6812 SvIVX(dstr) = SvIVX(sstr);
6814 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6815 else if (SvPVX(sstr) && SvLEN(sstr))
6816 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6818 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6821 SvANY(dstr) = new_XPVNV();
6822 SvCUR(dstr) = SvCUR(sstr);
6823 SvLEN(dstr) = SvLEN(sstr);
6824 SvIVX(dstr) = SvIVX(sstr);
6825 SvNVX(dstr) = SvNVX(sstr);
6827 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6828 else if (SvPVX(sstr) && SvLEN(sstr))
6829 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6831 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6834 SvANY(dstr) = new_XPVMG();
6835 SvCUR(dstr) = SvCUR(sstr);
6836 SvLEN(dstr) = SvLEN(sstr);
6837 SvIVX(dstr) = SvIVX(sstr);
6838 SvNVX(dstr) = SvNVX(sstr);
6839 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6840 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6842 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6843 else if (SvPVX(sstr) && SvLEN(sstr))
6844 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6846 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6849 SvANY(dstr) = new_XPVBM();
6850 SvCUR(dstr) = SvCUR(sstr);
6851 SvLEN(dstr) = SvLEN(sstr);
6852 SvIVX(dstr) = SvIVX(sstr);
6853 SvNVX(dstr) = SvNVX(sstr);
6854 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6855 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6857 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6858 else if (SvPVX(sstr) && SvLEN(sstr))
6859 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6861 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6862 BmRARE(dstr) = BmRARE(sstr);
6863 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6864 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6867 SvANY(dstr) = new_XPVLV();
6868 SvCUR(dstr) = SvCUR(sstr);
6869 SvLEN(dstr) = SvLEN(sstr);
6870 SvIVX(dstr) = SvIVX(sstr);
6871 SvNVX(dstr) = SvNVX(sstr);
6872 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6873 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6875 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6876 else if (SvPVX(sstr) && SvLEN(sstr))
6877 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6879 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6880 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6881 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6882 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6883 LvTYPE(dstr) = LvTYPE(sstr);
6886 SvANY(dstr) = new_XPVGV();
6887 SvCUR(dstr) = SvCUR(sstr);
6888 SvLEN(dstr) = SvLEN(sstr);
6889 SvIVX(dstr) = SvIVX(sstr);
6890 SvNVX(dstr) = SvNVX(sstr);
6891 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6892 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6894 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6895 else if (SvPVX(sstr) && SvLEN(sstr))
6896 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6898 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6899 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6900 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6901 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6902 GvFLAGS(dstr) = GvFLAGS(sstr);
6903 GvGP(dstr) = gp_dup(GvGP(sstr));
6904 (void)GpREFCNT_inc(GvGP(dstr));
6907 SvANY(dstr) = new_XPVIO();
6908 SvCUR(dstr) = SvCUR(sstr);
6909 SvLEN(dstr) = SvLEN(sstr);
6910 SvIVX(dstr) = SvIVX(sstr);
6911 SvNVX(dstr) = SvNVX(sstr);
6912 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6913 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6915 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6916 else if (SvPVX(sstr) && SvLEN(sstr))
6917 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6919 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6920 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6921 if (IoOFP(sstr) == IoIFP(sstr))
6922 IoOFP(dstr) = IoIFP(dstr);
6924 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6925 /* PL_rsfp_filters entries have fake IoDIRP() */
6926 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6927 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6929 IoDIRP(dstr) = IoDIRP(sstr);
6930 IoLINES(dstr) = IoLINES(sstr);
6931 IoPAGE(dstr) = IoPAGE(sstr);
6932 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6933 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6934 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6935 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6936 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6937 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6938 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6939 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6940 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6941 IoTYPE(dstr) = IoTYPE(sstr);
6942 IoFLAGS(dstr) = IoFLAGS(sstr);
6945 SvANY(dstr) = new_XPVAV();
6946 SvCUR(dstr) = SvCUR(sstr);
6947 SvLEN(dstr) = SvLEN(sstr);
6948 SvIVX(dstr) = SvIVX(sstr);
6949 SvNVX(dstr) = SvNVX(sstr);
6950 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6951 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6952 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6953 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6954 if (AvARRAY((AV*)sstr)) {
6955 SV **dst_ary, **src_ary;
6956 SSize_t items = AvFILLp((AV*)sstr) + 1;
6958 src_ary = AvARRAY((AV*)sstr);
6959 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6960 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6961 SvPVX(dstr) = (char*)dst_ary;
6962 AvALLOC((AV*)dstr) = dst_ary;
6963 if (AvREAL((AV*)sstr)) {
6965 *dst_ary++ = sv_dup_inc(*src_ary++);
6969 *dst_ary++ = sv_dup(*src_ary++);
6971 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6972 while (items-- > 0) {
6973 *dst_ary++ = &PL_sv_undef;
6977 SvPVX(dstr) = Nullch;
6978 AvALLOC((AV*)dstr) = (SV**)NULL;
6982 SvANY(dstr) = new_XPVHV();
6983 SvCUR(dstr) = SvCUR(sstr);
6984 SvLEN(dstr) = SvLEN(sstr);
6985 SvIVX(dstr) = SvIVX(sstr);
6986 SvNVX(dstr) = SvNVX(sstr);
6987 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6988 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6989 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6990 if (HvARRAY((HV*)sstr)) {
6992 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6993 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6994 Newz(0, dxhv->xhv_array,
6995 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6996 while (i <= sxhv->xhv_max) {
6997 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
6998 !!HvSHAREKEYS(sstr));
7001 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7004 SvPVX(dstr) = Nullch;
7005 HvEITER((HV*)dstr) = (HE*)NULL;
7007 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7008 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7011 SvANY(dstr) = new_XPVFM();
7012 FmLINES(dstr) = FmLINES(sstr);
7016 SvANY(dstr) = new_XPVCV();
7018 SvCUR(dstr) = SvCUR(sstr);
7019 SvLEN(dstr) = SvLEN(sstr);
7020 SvIVX(dstr) = SvIVX(sstr);
7021 SvNVX(dstr) = SvNVX(sstr);
7022 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7023 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7024 if (SvPVX(sstr) && SvLEN(sstr))
7025 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7027 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7028 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7029 CvSTART(dstr) = CvSTART(sstr);
7030 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7031 CvXSUB(dstr) = CvXSUB(sstr);
7032 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7033 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7034 CvDEPTH(dstr) = CvDEPTH(sstr);
7035 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7036 /* XXX padlists are real, but pretend to be not */
7037 AvREAL_on(CvPADLIST(sstr));
7038 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7039 AvREAL_off(CvPADLIST(sstr));
7040 AvREAL_off(CvPADLIST(dstr));
7043 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7044 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7045 CvFLAGS(dstr) = CvFLAGS(sstr);
7048 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7052 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7059 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7064 return (PERL_CONTEXT*)NULL;
7066 /* look for it in the table first */
7067 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7071 /* create anew and remember what it is */
7072 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7073 ptr_table_store(PL_ptr_table, cxs, ncxs);
7076 PERL_CONTEXT *cx = &cxs[ix];
7077 PERL_CONTEXT *ncx = &ncxs[ix];
7078 ncx->cx_type = cx->cx_type;
7079 if (CxTYPE(cx) == CXt_SUBST) {
7080 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7083 ncx->blk_oldsp = cx->blk_oldsp;
7084 ncx->blk_oldcop = cx->blk_oldcop;
7085 ncx->blk_oldretsp = cx->blk_oldretsp;
7086 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7087 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7088 ncx->blk_oldpm = cx->blk_oldpm;
7089 ncx->blk_gimme = cx->blk_gimme;
7090 switch (CxTYPE(cx)) {
7092 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7093 ? cv_dup_inc(cx->blk_sub.cv)
7094 : cv_dup(cx->blk_sub.cv));
7095 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7096 ? av_dup_inc(cx->blk_sub.argarray)
7098 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7099 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7100 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7101 ncx->blk_sub.lval = cx->blk_sub.lval;
7104 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7105 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7106 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7107 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7108 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7111 ncx->blk_loop.label = cx->blk_loop.label;
7112 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7113 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7114 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7115 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7116 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7117 ? cx->blk_loop.iterdata
7118 : gv_dup((GV*)cx->blk_loop.iterdata));
7119 ncx->blk_loop.oldcurpad
7120 = (SV**)ptr_table_fetch(PL_ptr_table,
7121 cx->blk_loop.oldcurpad);
7122 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7123 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7124 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7125 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7126 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7129 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7130 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7131 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7132 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7145 Perl_si_dup(pTHX_ PERL_SI *si)
7150 return (PERL_SI*)NULL;
7152 /* look for it in the table first */
7153 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7157 /* create anew and remember what it is */
7158 Newz(56, nsi, 1, PERL_SI);
7159 ptr_table_store(PL_ptr_table, si, nsi);
7161 nsi->si_stack = av_dup_inc(si->si_stack);
7162 nsi->si_cxix = si->si_cxix;
7163 nsi->si_cxmax = si->si_cxmax;
7164 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7165 nsi->si_type = si->si_type;
7166 nsi->si_prev = si_dup(si->si_prev);
7167 nsi->si_next = si_dup(si->si_next);
7168 nsi->si_markoff = si->si_markoff;
7173 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7174 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7175 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7176 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7177 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7178 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7179 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7180 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7181 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7182 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7183 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7184 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7187 #define pv_dup_inc(p) SAVEPV(p)
7188 #define pv_dup(p) SAVEPV(p)
7189 #define svp_dup_inc(p,pp) any_dup(p,pp)
7192 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7199 /* look for it in the table first */
7200 ret = ptr_table_fetch(PL_ptr_table, v);
7204 /* see if it is part of the interpreter structure */
7205 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7206 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7214 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7216 ANY *ss = proto_perl->Tsavestack;
7217 I32 ix = proto_perl->Tsavestack_ix;
7218 I32 max = proto_perl->Tsavestack_max;
7231 void (*dptr) (void*);
7232 void (*dxptr) (pTHXo_ void*);
7235 Newz(54, nss, max, ANY);
7241 case SAVEt_ITEM: /* normal string */
7242 sv = (SV*)POPPTR(ss,ix);
7243 TOPPTR(nss,ix) = sv_dup_inc(sv);
7244 sv = (SV*)POPPTR(ss,ix);
7245 TOPPTR(nss,ix) = sv_dup_inc(sv);
7247 case SAVEt_SV: /* scalar reference */
7248 sv = (SV*)POPPTR(ss,ix);
7249 TOPPTR(nss,ix) = sv_dup_inc(sv);
7250 gv = (GV*)POPPTR(ss,ix);
7251 TOPPTR(nss,ix) = gv_dup_inc(gv);
7253 case SAVEt_GENERIC_PVREF: /* generic char* */
7254 c = (char*)POPPTR(ss,ix);
7255 TOPPTR(nss,ix) = pv_dup(c);
7256 ptr = POPPTR(ss,ix);
7257 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7259 case SAVEt_GENERIC_SVREF: /* generic sv */
7260 case SAVEt_SVREF: /* scalar reference */
7261 sv = (SV*)POPPTR(ss,ix);
7262 TOPPTR(nss,ix) = sv_dup_inc(sv);
7263 ptr = POPPTR(ss,ix);
7264 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7266 case SAVEt_AV: /* array reference */
7267 av = (AV*)POPPTR(ss,ix);
7268 TOPPTR(nss,ix) = av_dup_inc(av);
7269 gv = (GV*)POPPTR(ss,ix);
7270 TOPPTR(nss,ix) = gv_dup(gv);
7272 case SAVEt_HV: /* hash reference */
7273 hv = (HV*)POPPTR(ss,ix);
7274 TOPPTR(nss,ix) = hv_dup_inc(hv);
7275 gv = (GV*)POPPTR(ss,ix);
7276 TOPPTR(nss,ix) = gv_dup(gv);
7278 case SAVEt_INT: /* int reference */
7279 ptr = POPPTR(ss,ix);
7280 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7281 intval = (int)POPINT(ss,ix);
7282 TOPINT(nss,ix) = intval;
7284 case SAVEt_LONG: /* long reference */
7285 ptr = POPPTR(ss,ix);
7286 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7287 longval = (long)POPLONG(ss,ix);
7288 TOPLONG(nss,ix) = longval;
7290 case SAVEt_I32: /* I32 reference */
7291 case SAVEt_I16: /* I16 reference */
7292 case SAVEt_I8: /* I8 reference */
7293 ptr = POPPTR(ss,ix);
7294 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7298 case SAVEt_IV: /* IV reference */
7299 ptr = POPPTR(ss,ix);
7300 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7304 case SAVEt_SPTR: /* SV* reference */
7305 ptr = POPPTR(ss,ix);
7306 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7307 sv = (SV*)POPPTR(ss,ix);
7308 TOPPTR(nss,ix) = sv_dup(sv);
7310 case SAVEt_VPTR: /* random* reference */
7311 ptr = POPPTR(ss,ix);
7312 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7313 ptr = POPPTR(ss,ix);
7314 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7316 case SAVEt_PPTR: /* char* reference */
7317 ptr = POPPTR(ss,ix);
7318 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7319 c = (char*)POPPTR(ss,ix);
7320 TOPPTR(nss,ix) = pv_dup(c);
7322 case SAVEt_HPTR: /* HV* reference */
7323 ptr = POPPTR(ss,ix);
7324 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7325 hv = (HV*)POPPTR(ss,ix);
7326 TOPPTR(nss,ix) = hv_dup(hv);
7328 case SAVEt_APTR: /* AV* reference */
7329 ptr = POPPTR(ss,ix);
7330 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7331 av = (AV*)POPPTR(ss,ix);
7332 TOPPTR(nss,ix) = av_dup(av);
7335 gv = (GV*)POPPTR(ss,ix);
7336 TOPPTR(nss,ix) = gv_dup(gv);
7338 case SAVEt_GP: /* scalar reference */
7339 gp = (GP*)POPPTR(ss,ix);
7340 TOPPTR(nss,ix) = gp = gp_dup(gp);
7341 (void)GpREFCNT_inc(gp);
7342 gv = (GV*)POPPTR(ss,ix);
7343 TOPPTR(nss,ix) = gv_dup_inc(c);
7344 c = (char*)POPPTR(ss,ix);
7345 TOPPTR(nss,ix) = pv_dup(c);
7352 sv = (SV*)POPPTR(ss,ix);
7353 TOPPTR(nss,ix) = sv_dup_inc(sv);
7356 ptr = POPPTR(ss,ix);
7357 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7358 /* these are assumed to be refcounted properly */
7359 switch (((OP*)ptr)->op_type) {
7366 TOPPTR(nss,ix) = ptr;
7371 TOPPTR(nss,ix) = Nullop;
7376 TOPPTR(nss,ix) = Nullop;
7379 c = (char*)POPPTR(ss,ix);
7380 TOPPTR(nss,ix) = pv_dup_inc(c);
7383 longval = POPLONG(ss,ix);
7384 TOPLONG(nss,ix) = longval;
7387 hv = (HV*)POPPTR(ss,ix);
7388 TOPPTR(nss,ix) = hv_dup_inc(hv);
7389 c = (char*)POPPTR(ss,ix);
7390 TOPPTR(nss,ix) = pv_dup_inc(c);
7394 case SAVEt_DESTRUCTOR:
7395 ptr = POPPTR(ss,ix);
7396 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7397 dptr = POPDPTR(ss,ix);
7398 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7400 case SAVEt_DESTRUCTOR_X:
7401 ptr = POPPTR(ss,ix);
7402 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7403 dxptr = POPDXPTR(ss,ix);
7404 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7406 case SAVEt_REGCONTEXT:
7412 case SAVEt_STACK_POS: /* Position on Perl stack */
7416 case SAVEt_AELEM: /* array element */
7417 sv = (SV*)POPPTR(ss,ix);
7418 TOPPTR(nss,ix) = sv_dup_inc(sv);
7421 av = (AV*)POPPTR(ss,ix);
7422 TOPPTR(nss,ix) = av_dup_inc(av);
7424 case SAVEt_HELEM: /* hash element */
7425 sv = (SV*)POPPTR(ss,ix);
7426 TOPPTR(nss,ix) = sv_dup_inc(sv);
7427 sv = (SV*)POPPTR(ss,ix);
7428 TOPPTR(nss,ix) = sv_dup_inc(sv);
7429 hv = (HV*)POPPTR(ss,ix);
7430 TOPPTR(nss,ix) = hv_dup_inc(hv);
7433 ptr = POPPTR(ss,ix);
7434 TOPPTR(nss,ix) = ptr;
7441 av = (AV*)POPPTR(ss,ix);
7442 TOPPTR(nss,ix) = av_dup(av);
7445 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7457 perl_clone(PerlInterpreter *proto_perl, UV flags)
7460 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7463 #ifdef PERL_IMPLICIT_SYS
7464 return perl_clone_using(proto_perl, flags,
7466 proto_perl->IMemShared,
7467 proto_perl->IMemParse,
7477 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7478 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7479 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7480 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7481 struct IPerlDir* ipD, struct IPerlSock* ipS,
7482 struct IPerlProc* ipP)
7484 /* XXX many of the string copies here can be optimized if they're
7485 * constants; they need to be allocated as common memory and just
7486 * their pointers copied. */
7490 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7492 PERL_SET_THX(pPerl);
7493 # else /* !PERL_OBJECT */
7494 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7495 PERL_SET_THX(my_perl);
7498 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7503 # else /* !DEBUGGING */
7504 Zero(my_perl, 1, PerlInterpreter);
7505 # endif /* DEBUGGING */
7509 PL_MemShared = ipMS;
7517 # endif /* PERL_OBJECT */
7518 #else /* !PERL_IMPLICIT_SYS */
7520 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7521 PERL_SET_THX(my_perl);
7524 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7529 # else /* !DEBUGGING */
7530 Zero(my_perl, 1, PerlInterpreter);
7531 # endif /* DEBUGGING */
7532 #endif /* PERL_IMPLICIT_SYS */
7535 PL_xiv_arenaroot = NULL;
7537 PL_xnv_arenaroot = NULL;
7539 PL_xrv_arenaroot = NULL;
7541 PL_xpv_arenaroot = NULL;
7543 PL_xpviv_arenaroot = NULL;
7544 PL_xpviv_root = NULL;
7545 PL_xpvnv_arenaroot = NULL;
7546 PL_xpvnv_root = NULL;
7547 PL_xpvcv_arenaroot = NULL;
7548 PL_xpvcv_root = NULL;
7549 PL_xpvav_arenaroot = NULL;
7550 PL_xpvav_root = NULL;
7551 PL_xpvhv_arenaroot = NULL;
7552 PL_xpvhv_root = NULL;
7553 PL_xpvmg_arenaroot = NULL;
7554 PL_xpvmg_root = NULL;
7555 PL_xpvlv_arenaroot = NULL;
7556 PL_xpvlv_root = NULL;
7557 PL_xpvbm_arenaroot = NULL;
7558 PL_xpvbm_root = NULL;
7559 PL_he_arenaroot = NULL;
7561 PL_nice_chunk = NULL;
7562 PL_nice_chunk_size = 0;
7565 PL_sv_root = Nullsv;
7566 PL_sv_arenaroot = Nullsv;
7568 PL_debug = proto_perl->Idebug;
7570 /* create SV map for pointer relocation */
7571 PL_ptr_table = ptr_table_new();
7573 /* initialize these special pointers as early as possible */
7574 SvANY(&PL_sv_undef) = NULL;
7575 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7576 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7577 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7580 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7582 SvANY(&PL_sv_no) = new_XPVNV();
7584 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7585 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7586 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7587 SvCUR(&PL_sv_no) = 0;
7588 SvLEN(&PL_sv_no) = 1;
7589 SvNVX(&PL_sv_no) = 0;
7590 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7593 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7595 SvANY(&PL_sv_yes) = new_XPVNV();
7597 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7598 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7599 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7600 SvCUR(&PL_sv_yes) = 1;
7601 SvLEN(&PL_sv_yes) = 2;
7602 SvNVX(&PL_sv_yes) = 1;
7603 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7605 /* create shared string table */
7606 PL_strtab = newHV();
7607 HvSHAREKEYS_off(PL_strtab);
7608 hv_ksplit(PL_strtab, 512);
7609 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7611 PL_compiling = proto_perl->Icompiling;
7612 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7613 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7614 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7615 if (!specialWARN(PL_compiling.cop_warnings))
7616 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7617 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7619 /* pseudo environmental stuff */
7620 PL_origargc = proto_perl->Iorigargc;
7622 New(0, PL_origargv, i+1, char*);
7623 PL_origargv[i] = '\0';
7625 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7627 PL_envgv = gv_dup(proto_perl->Ienvgv);
7628 PL_incgv = gv_dup(proto_perl->Iincgv);
7629 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7630 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7631 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7632 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7635 PL_minus_c = proto_perl->Iminus_c;
7636 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7637 PL_localpatches = proto_perl->Ilocalpatches;
7638 PL_splitstr = proto_perl->Isplitstr;
7639 PL_preprocess = proto_perl->Ipreprocess;
7640 PL_minus_n = proto_perl->Iminus_n;
7641 PL_minus_p = proto_perl->Iminus_p;
7642 PL_minus_l = proto_perl->Iminus_l;
7643 PL_minus_a = proto_perl->Iminus_a;
7644 PL_minus_F = proto_perl->Iminus_F;
7645 PL_doswitches = proto_perl->Idoswitches;
7646 PL_dowarn = proto_perl->Idowarn;
7647 PL_doextract = proto_perl->Idoextract;
7648 PL_sawampersand = proto_perl->Isawampersand;
7649 PL_unsafe = proto_perl->Iunsafe;
7650 PL_inplace = SAVEPV(proto_perl->Iinplace);
7651 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7652 PL_perldb = proto_perl->Iperldb;
7653 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7655 /* magical thingies */
7656 /* XXX time(&PL_basetime) when asked for? */
7657 PL_basetime = proto_perl->Ibasetime;
7658 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7660 PL_maxsysfd = proto_perl->Imaxsysfd;
7661 PL_multiline = proto_perl->Imultiline;
7662 PL_statusvalue = proto_perl->Istatusvalue;
7664 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7667 /* shortcuts to various I/O objects */
7668 PL_stdingv = gv_dup(proto_perl->Istdingv);
7669 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7670 PL_defgv = gv_dup(proto_perl->Idefgv);
7671 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7672 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7673 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7675 /* shortcuts to regexp stuff */
7676 PL_replgv = gv_dup(proto_perl->Ireplgv);
7678 /* shortcuts to misc objects */
7679 PL_errgv = gv_dup(proto_perl->Ierrgv);
7681 /* shortcuts to debugging objects */
7682 PL_DBgv = gv_dup(proto_perl->IDBgv);
7683 PL_DBline = gv_dup(proto_perl->IDBline);
7684 PL_DBsub = gv_dup(proto_perl->IDBsub);
7685 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7686 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7687 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7688 PL_lineary = av_dup(proto_perl->Ilineary);
7689 PL_dbargs = av_dup(proto_perl->Idbargs);
7692 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7693 PL_curstash = hv_dup(proto_perl->Tcurstash);
7694 PL_debstash = hv_dup(proto_perl->Idebstash);
7695 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7696 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7698 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7699 PL_endav = av_dup_inc(proto_perl->Iendav);
7700 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7701 PL_initav = av_dup_inc(proto_perl->Iinitav);
7703 PL_sub_generation = proto_perl->Isub_generation;
7705 /* funky return mechanisms */
7706 PL_forkprocess = proto_perl->Iforkprocess;
7708 /* subprocess state */
7709 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7711 /* internal state */
7712 PL_tainting = proto_perl->Itainting;
7713 PL_maxo = proto_perl->Imaxo;
7714 if (proto_perl->Iop_mask)
7715 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7717 PL_op_mask = Nullch;
7719 /* current interpreter roots */
7720 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7721 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7722 PL_main_start = proto_perl->Imain_start;
7723 PL_eval_root = proto_perl->Ieval_root;
7724 PL_eval_start = proto_perl->Ieval_start;
7726 /* runtime control stuff */
7727 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7728 PL_copline = proto_perl->Icopline;
7730 PL_filemode = proto_perl->Ifilemode;
7731 PL_lastfd = proto_perl->Ilastfd;
7732 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7735 PL_gensym = proto_perl->Igensym;
7736 PL_preambled = proto_perl->Ipreambled;
7737 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7738 PL_laststatval = proto_perl->Ilaststatval;
7739 PL_laststype = proto_perl->Ilaststype;
7740 PL_mess_sv = Nullsv;
7742 PL_orslen = proto_perl->Iorslen;
7743 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7744 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7746 /* interpreter atexit processing */
7747 PL_exitlistlen = proto_perl->Iexitlistlen;
7748 if (PL_exitlistlen) {
7749 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7750 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7753 PL_exitlist = (PerlExitListEntry*)NULL;
7754 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7756 PL_profiledata = NULL;
7757 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7758 /* PL_rsfp_filters entries have fake IoDIRP() */
7759 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7761 PL_compcv = cv_dup(proto_perl->Icompcv);
7762 PL_comppad = av_dup(proto_perl->Icomppad);
7763 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7764 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7765 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7766 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7767 proto_perl->Tcurpad);
7769 #ifdef HAVE_INTERP_INTERN
7770 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7773 /* more statics moved here */
7774 PL_generation = proto_perl->Igeneration;
7775 PL_DBcv = cv_dup(proto_perl->IDBcv);
7777 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7778 PL_in_clean_all = proto_perl->Iin_clean_all;
7780 PL_uid = proto_perl->Iuid;
7781 PL_euid = proto_perl->Ieuid;
7782 PL_gid = proto_perl->Igid;
7783 PL_egid = proto_perl->Iegid;
7784 PL_nomemok = proto_perl->Inomemok;
7785 PL_an = proto_perl->Ian;
7786 PL_cop_seqmax = proto_perl->Icop_seqmax;
7787 PL_op_seqmax = proto_perl->Iop_seqmax;
7788 PL_evalseq = proto_perl->Ievalseq;
7789 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7790 PL_origalen = proto_perl->Iorigalen;
7791 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7792 PL_osname = SAVEPV(proto_perl->Iosname);
7793 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7794 PL_sighandlerp = proto_perl->Isighandlerp;
7797 PL_runops = proto_perl->Irunops;
7799 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7802 PL_cshlen = proto_perl->Icshlen;
7803 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7806 PL_lex_state = proto_perl->Ilex_state;
7807 PL_lex_defer = proto_perl->Ilex_defer;
7808 PL_lex_expect = proto_perl->Ilex_expect;
7809 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7810 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7811 PL_lex_starts = proto_perl->Ilex_starts;
7812 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7813 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7814 PL_lex_op = proto_perl->Ilex_op;
7815 PL_lex_inpat = proto_perl->Ilex_inpat;
7816 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7817 PL_lex_brackets = proto_perl->Ilex_brackets;
7818 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7819 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7820 PL_lex_casemods = proto_perl->Ilex_casemods;
7821 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7822 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7824 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7825 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7826 PL_nexttoke = proto_perl->Inexttoke;
7828 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7829 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7830 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7831 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7832 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7833 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7834 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7835 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7836 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7837 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7838 PL_pending_ident = proto_perl->Ipending_ident;
7839 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7841 PL_expect = proto_perl->Iexpect;
7843 PL_multi_start = proto_perl->Imulti_start;
7844 PL_multi_end = proto_perl->Imulti_end;
7845 PL_multi_open = proto_perl->Imulti_open;
7846 PL_multi_close = proto_perl->Imulti_close;
7848 PL_error_count = proto_perl->Ierror_count;
7849 PL_subline = proto_perl->Isubline;
7850 PL_subname = sv_dup_inc(proto_perl->Isubname);
7852 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7853 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7854 PL_padix = proto_perl->Ipadix;
7855 PL_padix_floor = proto_perl->Ipadix_floor;
7856 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7858 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7859 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7860 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7861 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7862 PL_last_lop_op = proto_perl->Ilast_lop_op;
7863 PL_in_my = proto_perl->Iin_my;
7864 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7866 PL_cryptseen = proto_perl->Icryptseen;
7869 PL_hints = proto_perl->Ihints;
7871 PL_amagic_generation = proto_perl->Iamagic_generation;
7873 #ifdef USE_LOCALE_COLLATE
7874 PL_collation_ix = proto_perl->Icollation_ix;
7875 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7876 PL_collation_standard = proto_perl->Icollation_standard;
7877 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7878 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7879 #endif /* USE_LOCALE_COLLATE */
7881 #ifdef USE_LOCALE_NUMERIC
7882 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7883 PL_numeric_standard = proto_perl->Inumeric_standard;
7884 PL_numeric_local = proto_perl->Inumeric_local;
7885 PL_numeric_radix = proto_perl->Inumeric_radix;
7886 #endif /* !USE_LOCALE_NUMERIC */
7888 /* utf8 character classes */
7889 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7890 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7891 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7892 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7893 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7894 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7895 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7896 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7897 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7898 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7899 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7900 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7901 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7902 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7903 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7904 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7905 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7908 PL_last_swash_hv = Nullhv; /* reinits on demand */
7909 PL_last_swash_klen = 0;
7910 PL_last_swash_key[0]= '\0';
7911 PL_last_swash_tmps = (U8*)NULL;
7912 PL_last_swash_slen = 0;
7914 /* perly.c globals */
7915 PL_yydebug = proto_perl->Iyydebug;
7916 PL_yynerrs = proto_perl->Iyynerrs;
7917 PL_yyerrflag = proto_perl->Iyyerrflag;
7918 PL_yychar = proto_perl->Iyychar;
7919 PL_yyval = proto_perl->Iyyval;
7920 PL_yylval = proto_perl->Iyylval;
7922 PL_glob_index = proto_perl->Iglob_index;
7923 PL_srand_called = proto_perl->Isrand_called;
7924 PL_uudmap['M'] = 0; /* reinits on demand */
7925 PL_bitcount = Nullch; /* reinits on demand */
7927 if (proto_perl->Ipsig_ptr) {
7928 int sig_num[] = { SIG_NUM };
7929 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7930 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7931 for (i = 1; PL_sig_name[i]; i++) {
7932 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7933 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7937 PL_psig_ptr = (SV**)NULL;
7938 PL_psig_name = (SV**)NULL;
7941 /* thrdvar.h stuff */
7944 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7945 PL_tmps_ix = proto_perl->Ttmps_ix;
7946 PL_tmps_max = proto_perl->Ttmps_max;
7947 PL_tmps_floor = proto_perl->Ttmps_floor;
7948 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7950 while (i <= PL_tmps_ix) {
7951 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7955 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7956 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7957 Newz(54, PL_markstack, i, I32);
7958 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7959 - proto_perl->Tmarkstack);
7960 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7961 - proto_perl->Tmarkstack);
7962 Copy(proto_perl->Tmarkstack, PL_markstack,
7963 PL_markstack_ptr - PL_markstack + 1, I32);
7965 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7966 * NOTE: unlike the others! */
7967 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7968 PL_scopestack_max = proto_perl->Tscopestack_max;
7969 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7970 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7972 /* next push_return() sets PL_retstack[PL_retstack_ix]
7973 * NOTE: unlike the others! */
7974 PL_retstack_ix = proto_perl->Tretstack_ix;
7975 PL_retstack_max = proto_perl->Tretstack_max;
7976 Newz(54, PL_retstack, PL_retstack_max, OP*);
7977 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7979 /* NOTE: si_dup() looks at PL_markstack */
7980 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7982 /* PL_curstack = PL_curstackinfo->si_stack; */
7983 PL_curstack = av_dup(proto_perl->Tcurstack);
7984 PL_mainstack = av_dup(proto_perl->Tmainstack);
7986 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7987 PL_stack_base = AvARRAY(PL_curstack);
7988 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7989 - proto_perl->Tstack_base);
7990 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7992 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7993 * NOTE: unlike the others! */
7994 PL_savestack_ix = proto_perl->Tsavestack_ix;
7995 PL_savestack_max = proto_perl->Tsavestack_max;
7996 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7997 PL_savestack = ss_dup(proto_perl);
8001 ENTER; /* perl_destruct() wants to LEAVE; */
8004 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8005 PL_top_env = &PL_start_env;
8007 PL_op = proto_perl->Top;
8010 PL_Xpv = (XPV*)NULL;
8011 PL_na = proto_perl->Tna;
8013 PL_statbuf = proto_perl->Tstatbuf;
8014 PL_statcache = proto_perl->Tstatcache;
8015 PL_statgv = gv_dup(proto_perl->Tstatgv);
8016 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8018 PL_timesbuf = proto_perl->Ttimesbuf;
8021 PL_tainted = proto_perl->Ttainted;
8022 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8023 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8024 PL_rs = sv_dup_inc(proto_perl->Trs);
8025 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8026 PL_ofslen = proto_perl->Tofslen;
8027 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8028 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8029 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8030 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8031 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8032 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8034 PL_restartop = proto_perl->Trestartop;
8035 PL_in_eval = proto_perl->Tin_eval;
8036 PL_delaymagic = proto_perl->Tdelaymagic;
8037 PL_dirty = proto_perl->Tdirty;
8038 PL_localizing = proto_perl->Tlocalizing;
8040 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8041 PL_protect = proto_perl->Tprotect;
8043 PL_errors = sv_dup_inc(proto_perl->Terrors);
8044 PL_av_fetch_sv = Nullsv;
8045 PL_hv_fetch_sv = Nullsv;
8046 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8047 PL_modcount = proto_perl->Tmodcount;
8048 PL_lastgotoprobe = Nullop;
8049 PL_dumpindent = proto_perl->Tdumpindent;
8051 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8052 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8053 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8054 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8055 PL_sortcxix = proto_perl->Tsortcxix;
8056 PL_efloatbuf = Nullch; /* reinits on demand */
8057 PL_efloatsize = 0; /* reinits on demand */
8061 PL_screamfirst = NULL;
8062 PL_screamnext = NULL;
8063 PL_maxscream = -1; /* reinits on demand */
8064 PL_lastscream = Nullsv;
8066 PL_watchaddr = NULL;
8067 PL_watchok = Nullch;
8069 PL_regdummy = proto_perl->Tregdummy;
8070 PL_regcomp_parse = Nullch;
8071 PL_regxend = Nullch;
8072 PL_regcode = (regnode*)NULL;
8075 PL_regprecomp = Nullch;
8080 PL_seen_zerolen = 0;
8082 PL_regcomp_rx = (regexp*)NULL;
8084 PL_colorset = 0; /* reinits PL_colors[] */
8085 /*PL_colors[6] = {0,0,0,0,0,0};*/
8086 PL_reg_whilem_seen = 0;
8087 PL_reginput = Nullch;
8090 PL_regstartp = (I32*)NULL;
8091 PL_regendp = (I32*)NULL;
8092 PL_reglastparen = (U32*)NULL;
8093 PL_regtill = Nullch;
8095 PL_reg_start_tmp = (char**)NULL;
8096 PL_reg_start_tmpl = 0;
8097 PL_regdata = (struct reg_data*)NULL;
8100 PL_reg_eval_set = 0;
8102 PL_regprogram = (regnode*)NULL;
8104 PL_regcc = (CURCUR*)NULL;
8105 PL_reg_call_cc = (struct re_cc_state*)NULL;
8106 PL_reg_re = (regexp*)NULL;
8107 PL_reg_ganch = Nullch;
8109 PL_reg_magic = (MAGIC*)NULL;
8111 PL_reg_oldcurpm = (PMOP*)NULL;
8112 PL_reg_curpm = (PMOP*)NULL;
8113 PL_reg_oldsaved = Nullch;
8114 PL_reg_oldsavedlen = 0;
8116 PL_reg_leftiter = 0;
8117 PL_reg_poscache = Nullch;
8118 PL_reg_poscache_size= 0;
8120 /* RE engine - function pointers */
8121 PL_regcompp = proto_perl->Tregcompp;
8122 PL_regexecp = proto_perl->Tregexecp;
8123 PL_regint_start = proto_perl->Tregint_start;
8124 PL_regint_string = proto_perl->Tregint_string;
8125 PL_regfree = proto_perl->Tregfree;
8127 PL_reginterp_cnt = 0;
8128 PL_reg_starttry = 0;
8131 return (PerlInterpreter*)pPerl;
8137 #else /* !USE_ITHREADS */
8143 #endif /* USE_ITHREADS */
8146 do_report_used(pTHXo_ SV *sv)
8148 if (SvTYPE(sv) != SVTYPEMASK) {
8149 PerlIO_printf(Perl_debug_log, "****\n");
8155 do_clean_objs(pTHXo_ SV *sv)
8159 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8160 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8166 /* XXX Might want to check arrays, etc. */
8169 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8171 do_clean_named_objs(pTHXo_ SV *sv)
8173 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8174 if ( SvOBJECT(GvSV(sv)) ||
8175 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8176 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8177 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8178 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8180 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8188 do_clean_all(pTHXo_ SV *sv)
8190 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8191 SvFLAGS(sv) |= SVf_BREAK;