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, '*', Nullch, 0);
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)
6139 uv = PTR2UV(va_arg(*args, void*));
6141 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6161 iv = (IV)utf8_to_uv(vecstr, &ulen);
6171 case 'h': iv = (short)va_arg(*args, int); break;
6172 default: iv = va_arg(*args, int); break;
6173 case 'l': iv = va_arg(*args, long); break;
6174 case 'V': iv = va_arg(*args, IV); break;
6176 case 'q': iv = va_arg(*args, Quad_t); break;
6181 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6183 case 'h': iv = (short)iv; break;
6185 case 'l': iv = (long)iv; break;
6188 case 'q': iv = (Quad_t)iv; break;
6195 esignbuf[esignlen++] = plus;
6199 esignbuf[esignlen++] = '-';
6243 uv = utf8_to_uv(vecstr, &ulen);
6253 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6254 default: uv = va_arg(*args, unsigned); break;
6255 case 'l': uv = va_arg(*args, unsigned long); break;
6256 case 'V': uv = va_arg(*args, UV); break;
6258 case 'q': uv = va_arg(*args, Quad_t); break;
6263 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6265 case 'h': uv = (unsigned short)uv; break;
6267 case 'l': uv = (unsigned long)uv; break;
6270 case 'q': uv = (Quad_t)uv; break;
6276 eptr = ebuf + sizeof ebuf;
6282 p = (char*)((c == 'X')
6283 ? "0123456789ABCDEF" : "0123456789abcdef");
6289 esignbuf[esignlen++] = '0';
6290 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6296 *--eptr = '0' + dig;
6298 if (alt && *eptr != '0')
6304 *--eptr = '0' + dig;
6307 esignbuf[esignlen++] = '0';
6308 esignbuf[esignlen++] = 'b';
6311 default: /* it had better be ten or less */
6312 #if defined(PERL_Y2KWARN)
6313 if (ckWARN(WARN_Y2K)) {
6315 char *s = SvPV(sv,n);
6316 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6317 && (n == 2 || !isDIGIT(s[n-3])))
6319 Perl_warner(aTHX_ WARN_Y2K,
6320 "Possible Y2K bug: %%%c %s",
6321 c, "format string following '19'");
6327 *--eptr = '0' + dig;
6328 } while (uv /= base);
6331 elen = (ebuf + sizeof ebuf) - eptr;
6334 zeros = precis - elen;
6335 else if (precis == 0 && elen == 1 && *eptr == '0')
6340 /* FLOATING POINT */
6343 c = 'f'; /* maybe %F isn't supported here */
6349 /* This is evil, but floating point is even more evil */
6353 nv = va_arg(*args, NV);
6355 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6358 if (c != 'e' && c != 'E') {
6360 (void)Perl_frexp(nv, &i);
6361 if (i == PERL_INT_MIN)
6362 Perl_die(aTHX_ "panic: frexp");
6364 need = BIT_DIGITS(i);
6366 need += has_precis ? precis : 6; /* known default */
6370 need += 20; /* fudge factor */
6371 if (PL_efloatsize < need) {
6372 Safefree(PL_efloatbuf);
6373 PL_efloatsize = need + 20; /* more fudge */
6374 New(906, PL_efloatbuf, PL_efloatsize, char);
6375 PL_efloatbuf[0] = '\0';
6378 eptr = ebuf + sizeof ebuf;
6381 #ifdef USE_LONG_DOUBLE
6383 static char const my_prifldbl[] = PERL_PRIfldbl;
6384 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6385 while (p >= my_prifldbl) { *--eptr = *p--; }
6390 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6395 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6408 RESTORE_NUMERIC_STANDARD();
6409 (void)sprintf(PL_efloatbuf, eptr, nv);
6410 RESTORE_NUMERIC_LOCAL();
6413 eptr = PL_efloatbuf;
6414 elen = strlen(PL_efloatbuf);
6421 i = SvCUR(sv) - origlen;
6424 case 'h': *(va_arg(*args, short*)) = i; break;
6425 default: *(va_arg(*args, int*)) = i; break;
6426 case 'l': *(va_arg(*args, long*)) = i; break;
6427 case 'V': *(va_arg(*args, IV*)) = i; break;
6429 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6433 else if (svix < svmax)
6434 sv_setuv_mg(svargs[svix++], (UV)i);
6435 continue; /* not "break" */
6442 if (!args && ckWARN(WARN_PRINTF) &&
6443 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6444 SV *msg = sv_newmortal();
6445 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6446 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6449 Perl_sv_catpvf(aTHX_ msg,
6450 "\"%%%c\"", c & 0xFF);
6452 Perl_sv_catpvf(aTHX_ msg,
6453 "\"%%\\%03"UVof"\"",
6456 sv_catpv(msg, "end of string");
6457 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6460 /* output mangled stuff ... */
6466 /* ... right here, because formatting flags should not apply */
6467 SvGROW(sv, SvCUR(sv) + elen + 1);
6469 memcpy(p, eptr, elen);
6472 SvCUR(sv) = p - SvPVX(sv);
6473 continue; /* not "break" */
6476 have = esignlen + zeros + elen;
6477 need = (have > width ? have : width);
6480 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6482 if (esignlen && fill == '0') {
6483 for (i = 0; i < esignlen; i++)
6487 memset(p, fill, gap);
6490 if (esignlen && fill != '0') {
6491 for (i = 0; i < esignlen; i++)
6495 for (i = zeros; i; i--)
6499 memcpy(p, eptr, elen);
6503 memset(p, ' ', gap);
6508 memcpy(p, dotstr, dotstrlen);
6512 vectorize = FALSE; /* done iterating over vecstr */
6517 SvCUR(sv) = p - SvPVX(sv);
6525 #if defined(USE_ITHREADS)
6527 #if defined(USE_THREADS)
6528 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6531 #ifndef GpREFCNT_inc
6532 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6536 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6537 #define av_dup(s) (AV*)sv_dup((SV*)s)
6538 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6539 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6540 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6541 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6542 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6543 #define io_dup(s) (IO*)sv_dup((SV*)s)
6544 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6545 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6546 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6547 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6548 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6551 Perl_re_dup(pTHX_ REGEXP *r)
6553 /* XXX fix when pmop->op_pmregexp becomes shared */
6554 return ReREFCNT_inc(r);
6558 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6562 return (PerlIO*)NULL;
6564 /* look for it in the table first */
6565 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6569 /* create anew and remember what it is */
6570 ret = PerlIO_fdupopen(fp);
6571 ptr_table_store(PL_ptr_table, fp, ret);
6576 Perl_dirp_dup(pTHX_ DIR *dp)
6585 Perl_gp_dup(pTHX_ GP *gp)
6590 /* look for it in the table first */
6591 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6595 /* create anew and remember what it is */
6596 Newz(0, ret, 1, GP);
6597 ptr_table_store(PL_ptr_table, gp, ret);
6600 ret->gp_refcnt = 0; /* must be before any other dups! */
6601 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6602 ret->gp_io = io_dup_inc(gp->gp_io);
6603 ret->gp_form = cv_dup_inc(gp->gp_form);
6604 ret->gp_av = av_dup_inc(gp->gp_av);
6605 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6606 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6607 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6608 ret->gp_cvgen = gp->gp_cvgen;
6609 ret->gp_flags = gp->gp_flags;
6610 ret->gp_line = gp->gp_line;
6611 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6616 Perl_mg_dup(pTHX_ MAGIC *mg)
6618 MAGIC *mgret = (MAGIC*)NULL;
6621 return (MAGIC*)NULL;
6622 /* look for it in the table first */
6623 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6627 for (; mg; mg = mg->mg_moremagic) {
6629 Newz(0, nmg, 1, MAGIC);
6633 mgprev->mg_moremagic = nmg;
6634 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6635 nmg->mg_private = mg->mg_private;
6636 nmg->mg_type = mg->mg_type;
6637 nmg->mg_flags = mg->mg_flags;
6638 if (mg->mg_type == 'r') {
6639 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6642 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6643 ? sv_dup_inc(mg->mg_obj)
6644 : sv_dup(mg->mg_obj);
6646 nmg->mg_len = mg->mg_len;
6647 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6648 if (mg->mg_ptr && mg->mg_type != 'g') {
6649 if (mg->mg_len >= 0) {
6650 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6651 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6652 AMT *amtp = (AMT*)mg->mg_ptr;
6653 AMT *namtp = (AMT*)nmg->mg_ptr;
6655 for (i = 1; i < NofAMmeth; i++) {
6656 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6660 else if (mg->mg_len == HEf_SVKEY)
6661 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6669 Perl_ptr_table_new(pTHX)
6672 Newz(0, tbl, 1, PTR_TBL_t);
6675 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6680 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6682 PTR_TBL_ENT_t *tblent;
6683 UV hash = PTR2UV(sv);
6685 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6686 for (; tblent; tblent = tblent->next) {
6687 if (tblent->oldval == sv)
6688 return tblent->newval;
6694 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6696 PTR_TBL_ENT_t *tblent, **otblent;
6697 /* XXX this may be pessimal on platforms where pointers aren't good
6698 * hash values e.g. if they grow faster in the most significant
6700 UV hash = PTR2UV(oldv);
6704 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6705 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6706 if (tblent->oldval == oldv) {
6707 tblent->newval = newv;
6712 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6713 tblent->oldval = oldv;
6714 tblent->newval = newv;
6715 tblent->next = *otblent;
6718 if (i && tbl->tbl_items > tbl->tbl_max)
6719 ptr_table_split(tbl);
6723 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6725 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6726 UV oldsize = tbl->tbl_max + 1;
6727 UV newsize = oldsize * 2;
6730 Renew(ary, newsize, PTR_TBL_ENT_t*);
6731 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6732 tbl->tbl_max = --newsize;
6734 for (i=0; i < oldsize; i++, ary++) {
6735 PTR_TBL_ENT_t **curentp, **entp, *ent;
6738 curentp = ary + oldsize;
6739 for (entp = ary, ent = *ary; ent; ent = *entp) {
6740 if ((newsize & PTR2UV(ent->oldval)) != i) {
6742 ent->next = *curentp;
6757 Perl_sv_dup(pTHX_ SV *sstr)
6761 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6763 /* look for it in the table first */
6764 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6768 /* create anew and remember what it is */
6770 ptr_table_store(PL_ptr_table, sstr, dstr);
6773 SvFLAGS(dstr) = SvFLAGS(sstr);
6774 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6775 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6778 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6779 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6780 PL_watch_pvx, SvPVX(sstr));
6783 switch (SvTYPE(sstr)) {
6788 SvANY(dstr) = new_XIV();
6789 SvIVX(dstr) = SvIVX(sstr);
6792 SvANY(dstr) = new_XNV();
6793 SvNVX(dstr) = SvNVX(sstr);
6796 SvANY(dstr) = new_XRV();
6797 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6800 SvANY(dstr) = new_XPV();
6801 SvCUR(dstr) = SvCUR(sstr);
6802 SvLEN(dstr) = SvLEN(sstr);
6804 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6805 else if (SvPVX(sstr) && SvLEN(sstr))
6806 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6808 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6811 SvANY(dstr) = new_XPVIV();
6812 SvCUR(dstr) = SvCUR(sstr);
6813 SvLEN(dstr) = SvLEN(sstr);
6814 SvIVX(dstr) = SvIVX(sstr);
6816 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6817 else if (SvPVX(sstr) && SvLEN(sstr))
6818 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6820 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6823 SvANY(dstr) = new_XPVNV();
6824 SvCUR(dstr) = SvCUR(sstr);
6825 SvLEN(dstr) = SvLEN(sstr);
6826 SvIVX(dstr) = SvIVX(sstr);
6827 SvNVX(dstr) = SvNVX(sstr);
6829 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6830 else if (SvPVX(sstr) && SvLEN(sstr))
6831 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6833 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6836 SvANY(dstr) = new_XPVMG();
6837 SvCUR(dstr) = SvCUR(sstr);
6838 SvLEN(dstr) = SvLEN(sstr);
6839 SvIVX(dstr) = SvIVX(sstr);
6840 SvNVX(dstr) = SvNVX(sstr);
6841 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6842 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6844 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6845 else if (SvPVX(sstr) && SvLEN(sstr))
6846 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6848 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6851 SvANY(dstr) = new_XPVBM();
6852 SvCUR(dstr) = SvCUR(sstr);
6853 SvLEN(dstr) = SvLEN(sstr);
6854 SvIVX(dstr) = SvIVX(sstr);
6855 SvNVX(dstr) = SvNVX(sstr);
6856 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6857 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6859 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6860 else if (SvPVX(sstr) && SvLEN(sstr))
6861 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6863 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6864 BmRARE(dstr) = BmRARE(sstr);
6865 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6866 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
6869 SvANY(dstr) = new_XPVLV();
6870 SvCUR(dstr) = SvCUR(sstr);
6871 SvLEN(dstr) = SvLEN(sstr);
6872 SvIVX(dstr) = SvIVX(sstr);
6873 SvNVX(dstr) = SvNVX(sstr);
6874 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6875 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6877 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6878 else if (SvPVX(sstr) && SvLEN(sstr))
6879 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6881 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6882 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
6883 LvTARGLEN(dstr) = LvTARGLEN(sstr);
6884 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
6885 LvTYPE(dstr) = LvTYPE(sstr);
6888 SvANY(dstr) = new_XPVGV();
6889 SvCUR(dstr) = SvCUR(sstr);
6890 SvLEN(dstr) = SvLEN(sstr);
6891 SvIVX(dstr) = SvIVX(sstr);
6892 SvNVX(dstr) = SvNVX(sstr);
6893 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6894 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6896 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6897 else if (SvPVX(sstr) && SvLEN(sstr))
6898 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6900 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6901 GvNAMELEN(dstr) = GvNAMELEN(sstr);
6902 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
6903 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
6904 GvFLAGS(dstr) = GvFLAGS(sstr);
6905 GvGP(dstr) = gp_dup(GvGP(sstr));
6906 (void)GpREFCNT_inc(GvGP(dstr));
6909 SvANY(dstr) = new_XPVIO();
6910 SvCUR(dstr) = SvCUR(sstr);
6911 SvLEN(dstr) = SvLEN(sstr);
6912 SvIVX(dstr) = SvIVX(sstr);
6913 SvNVX(dstr) = SvNVX(sstr);
6914 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6915 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6917 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6918 else if (SvPVX(sstr) && SvLEN(sstr))
6919 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6921 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6922 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
6923 if (IoOFP(sstr) == IoIFP(sstr))
6924 IoOFP(dstr) = IoIFP(dstr);
6926 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
6927 /* PL_rsfp_filters entries have fake IoDIRP() */
6928 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
6929 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
6931 IoDIRP(dstr) = IoDIRP(sstr);
6932 IoLINES(dstr) = IoLINES(sstr);
6933 IoPAGE(dstr) = IoPAGE(sstr);
6934 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
6935 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
6936 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
6937 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
6938 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
6939 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
6940 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
6941 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
6942 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
6943 IoTYPE(dstr) = IoTYPE(sstr);
6944 IoFLAGS(dstr) = IoFLAGS(sstr);
6947 SvANY(dstr) = new_XPVAV();
6948 SvCUR(dstr) = SvCUR(sstr);
6949 SvLEN(dstr) = SvLEN(sstr);
6950 SvIVX(dstr) = SvIVX(sstr);
6951 SvNVX(dstr) = SvNVX(sstr);
6952 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6953 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6954 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
6955 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
6956 if (AvARRAY((AV*)sstr)) {
6957 SV **dst_ary, **src_ary;
6958 SSize_t items = AvFILLp((AV*)sstr) + 1;
6960 src_ary = AvARRAY((AV*)sstr);
6961 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
6962 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
6963 SvPVX(dstr) = (char*)dst_ary;
6964 AvALLOC((AV*)dstr) = dst_ary;
6965 if (AvREAL((AV*)sstr)) {
6967 *dst_ary++ = sv_dup_inc(*src_ary++);
6971 *dst_ary++ = sv_dup(*src_ary++);
6973 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
6974 while (items-- > 0) {
6975 *dst_ary++ = &PL_sv_undef;
6979 SvPVX(dstr) = Nullch;
6980 AvALLOC((AV*)dstr) = (SV**)NULL;
6984 SvANY(dstr) = new_XPVHV();
6985 SvCUR(dstr) = SvCUR(sstr);
6986 SvLEN(dstr) = SvLEN(sstr);
6987 SvIVX(dstr) = SvIVX(sstr);
6988 SvNVX(dstr) = SvNVX(sstr);
6989 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6990 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6991 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
6992 if (HvARRAY((HV*)sstr)) {
6994 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
6995 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
6996 Newz(0, dxhv->xhv_array,
6997 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
6998 while (i <= sxhv->xhv_max) {
6999 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7000 !!HvSHAREKEYS(sstr));
7003 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7006 SvPVX(dstr) = Nullch;
7007 HvEITER((HV*)dstr) = (HE*)NULL;
7009 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7010 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7013 SvANY(dstr) = new_XPVFM();
7014 FmLINES(dstr) = FmLINES(sstr);
7018 SvANY(dstr) = new_XPVCV();
7020 SvCUR(dstr) = SvCUR(sstr);
7021 SvLEN(dstr) = SvLEN(sstr);
7022 SvIVX(dstr) = SvIVX(sstr);
7023 SvNVX(dstr) = SvNVX(sstr);
7024 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7025 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7026 if (SvPVX(sstr) && SvLEN(sstr))
7027 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7029 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7030 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7031 CvSTART(dstr) = CvSTART(sstr);
7032 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7033 CvXSUB(dstr) = CvXSUB(sstr);
7034 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7035 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7036 CvDEPTH(dstr) = CvDEPTH(sstr);
7037 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7038 /* XXX padlists are real, but pretend to be not */
7039 AvREAL_on(CvPADLIST(sstr));
7040 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7041 AvREAL_off(CvPADLIST(sstr));
7042 AvREAL_off(CvPADLIST(dstr));
7045 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7046 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7047 CvFLAGS(dstr) = CvFLAGS(sstr);
7050 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7054 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7061 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7066 return (PERL_CONTEXT*)NULL;
7068 /* look for it in the table first */
7069 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7073 /* create anew and remember what it is */
7074 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7075 ptr_table_store(PL_ptr_table, cxs, ncxs);
7078 PERL_CONTEXT *cx = &cxs[ix];
7079 PERL_CONTEXT *ncx = &ncxs[ix];
7080 ncx->cx_type = cx->cx_type;
7081 if (CxTYPE(cx) == CXt_SUBST) {
7082 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7085 ncx->blk_oldsp = cx->blk_oldsp;
7086 ncx->blk_oldcop = cx->blk_oldcop;
7087 ncx->blk_oldretsp = cx->blk_oldretsp;
7088 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7089 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7090 ncx->blk_oldpm = cx->blk_oldpm;
7091 ncx->blk_gimme = cx->blk_gimme;
7092 switch (CxTYPE(cx)) {
7094 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7095 ? cv_dup_inc(cx->blk_sub.cv)
7096 : cv_dup(cx->blk_sub.cv));
7097 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7098 ? av_dup_inc(cx->blk_sub.argarray)
7100 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7101 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7102 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7103 ncx->blk_sub.lval = cx->blk_sub.lval;
7106 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7107 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7108 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7109 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7110 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7113 ncx->blk_loop.label = cx->blk_loop.label;
7114 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7115 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7116 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7117 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7118 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7119 ? cx->blk_loop.iterdata
7120 : gv_dup((GV*)cx->blk_loop.iterdata));
7121 ncx->blk_loop.oldcurpad
7122 = (SV**)ptr_table_fetch(PL_ptr_table,
7123 cx->blk_loop.oldcurpad);
7124 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7125 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7126 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7127 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7128 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7131 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7132 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7133 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7134 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7147 Perl_si_dup(pTHX_ PERL_SI *si)
7152 return (PERL_SI*)NULL;
7154 /* look for it in the table first */
7155 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7159 /* create anew and remember what it is */
7160 Newz(56, nsi, 1, PERL_SI);
7161 ptr_table_store(PL_ptr_table, si, nsi);
7163 nsi->si_stack = av_dup_inc(si->si_stack);
7164 nsi->si_cxix = si->si_cxix;
7165 nsi->si_cxmax = si->si_cxmax;
7166 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7167 nsi->si_type = si->si_type;
7168 nsi->si_prev = si_dup(si->si_prev);
7169 nsi->si_next = si_dup(si->si_next);
7170 nsi->si_markoff = si->si_markoff;
7175 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7176 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7177 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7178 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7179 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7180 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7181 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7182 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7183 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7184 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7185 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7186 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7189 #define pv_dup_inc(p) SAVEPV(p)
7190 #define pv_dup(p) SAVEPV(p)
7191 #define svp_dup_inc(p,pp) any_dup(p,pp)
7194 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7201 /* look for it in the table first */
7202 ret = ptr_table_fetch(PL_ptr_table, v);
7206 /* see if it is part of the interpreter structure */
7207 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7208 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7216 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7218 ANY *ss = proto_perl->Tsavestack;
7219 I32 ix = proto_perl->Tsavestack_ix;
7220 I32 max = proto_perl->Tsavestack_max;
7233 void (*dptr) (void*);
7234 void (*dxptr) (pTHXo_ void*);
7237 Newz(54, nss, max, ANY);
7243 case SAVEt_ITEM: /* normal string */
7244 sv = (SV*)POPPTR(ss,ix);
7245 TOPPTR(nss,ix) = sv_dup_inc(sv);
7246 sv = (SV*)POPPTR(ss,ix);
7247 TOPPTR(nss,ix) = sv_dup_inc(sv);
7249 case SAVEt_SV: /* scalar reference */
7250 sv = (SV*)POPPTR(ss,ix);
7251 TOPPTR(nss,ix) = sv_dup_inc(sv);
7252 gv = (GV*)POPPTR(ss,ix);
7253 TOPPTR(nss,ix) = gv_dup_inc(gv);
7255 case SAVEt_GENERIC_PVREF: /* generic char* */
7256 c = (char*)POPPTR(ss,ix);
7257 TOPPTR(nss,ix) = pv_dup(c);
7258 ptr = POPPTR(ss,ix);
7259 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7261 case SAVEt_GENERIC_SVREF: /* generic sv */
7262 case SAVEt_SVREF: /* scalar reference */
7263 sv = (SV*)POPPTR(ss,ix);
7264 TOPPTR(nss,ix) = sv_dup_inc(sv);
7265 ptr = POPPTR(ss,ix);
7266 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7268 case SAVEt_AV: /* array reference */
7269 av = (AV*)POPPTR(ss,ix);
7270 TOPPTR(nss,ix) = av_dup_inc(av);
7271 gv = (GV*)POPPTR(ss,ix);
7272 TOPPTR(nss,ix) = gv_dup(gv);
7274 case SAVEt_HV: /* hash reference */
7275 hv = (HV*)POPPTR(ss,ix);
7276 TOPPTR(nss,ix) = hv_dup_inc(hv);
7277 gv = (GV*)POPPTR(ss,ix);
7278 TOPPTR(nss,ix) = gv_dup(gv);
7280 case SAVEt_INT: /* int reference */
7281 ptr = POPPTR(ss,ix);
7282 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7283 intval = (int)POPINT(ss,ix);
7284 TOPINT(nss,ix) = intval;
7286 case SAVEt_LONG: /* long reference */
7287 ptr = POPPTR(ss,ix);
7288 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7289 longval = (long)POPLONG(ss,ix);
7290 TOPLONG(nss,ix) = longval;
7292 case SAVEt_I32: /* I32 reference */
7293 case SAVEt_I16: /* I16 reference */
7294 case SAVEt_I8: /* I8 reference */
7295 ptr = POPPTR(ss,ix);
7296 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7300 case SAVEt_IV: /* IV reference */
7301 ptr = POPPTR(ss,ix);
7302 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7306 case SAVEt_SPTR: /* SV* reference */
7307 ptr = POPPTR(ss,ix);
7308 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7309 sv = (SV*)POPPTR(ss,ix);
7310 TOPPTR(nss,ix) = sv_dup(sv);
7312 case SAVEt_VPTR: /* random* reference */
7313 ptr = POPPTR(ss,ix);
7314 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7315 ptr = POPPTR(ss,ix);
7316 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7318 case SAVEt_PPTR: /* char* reference */
7319 ptr = POPPTR(ss,ix);
7320 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7321 c = (char*)POPPTR(ss,ix);
7322 TOPPTR(nss,ix) = pv_dup(c);
7324 case SAVEt_HPTR: /* HV* reference */
7325 ptr = POPPTR(ss,ix);
7326 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7327 hv = (HV*)POPPTR(ss,ix);
7328 TOPPTR(nss,ix) = hv_dup(hv);
7330 case SAVEt_APTR: /* AV* reference */
7331 ptr = POPPTR(ss,ix);
7332 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7333 av = (AV*)POPPTR(ss,ix);
7334 TOPPTR(nss,ix) = av_dup(av);
7337 gv = (GV*)POPPTR(ss,ix);
7338 TOPPTR(nss,ix) = gv_dup(gv);
7340 case SAVEt_GP: /* scalar reference */
7341 gp = (GP*)POPPTR(ss,ix);
7342 TOPPTR(nss,ix) = gp = gp_dup(gp);
7343 (void)GpREFCNT_inc(gp);
7344 gv = (GV*)POPPTR(ss,ix);
7345 TOPPTR(nss,ix) = gv_dup_inc(c);
7346 c = (char*)POPPTR(ss,ix);
7347 TOPPTR(nss,ix) = pv_dup(c);
7354 sv = (SV*)POPPTR(ss,ix);
7355 TOPPTR(nss,ix) = sv_dup_inc(sv);
7358 ptr = POPPTR(ss,ix);
7359 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7360 /* these are assumed to be refcounted properly */
7361 switch (((OP*)ptr)->op_type) {
7368 TOPPTR(nss,ix) = ptr;
7373 TOPPTR(nss,ix) = Nullop;
7378 TOPPTR(nss,ix) = Nullop;
7381 c = (char*)POPPTR(ss,ix);
7382 TOPPTR(nss,ix) = pv_dup_inc(c);
7385 longval = POPLONG(ss,ix);
7386 TOPLONG(nss,ix) = longval;
7389 hv = (HV*)POPPTR(ss,ix);
7390 TOPPTR(nss,ix) = hv_dup_inc(hv);
7391 c = (char*)POPPTR(ss,ix);
7392 TOPPTR(nss,ix) = pv_dup_inc(c);
7396 case SAVEt_DESTRUCTOR:
7397 ptr = POPPTR(ss,ix);
7398 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7399 dptr = POPDPTR(ss,ix);
7400 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7402 case SAVEt_DESTRUCTOR_X:
7403 ptr = POPPTR(ss,ix);
7404 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7405 dxptr = POPDXPTR(ss,ix);
7406 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7408 case SAVEt_REGCONTEXT:
7414 case SAVEt_STACK_POS: /* Position on Perl stack */
7418 case SAVEt_AELEM: /* array element */
7419 sv = (SV*)POPPTR(ss,ix);
7420 TOPPTR(nss,ix) = sv_dup_inc(sv);
7423 av = (AV*)POPPTR(ss,ix);
7424 TOPPTR(nss,ix) = av_dup_inc(av);
7426 case SAVEt_HELEM: /* hash element */
7427 sv = (SV*)POPPTR(ss,ix);
7428 TOPPTR(nss,ix) = sv_dup_inc(sv);
7429 sv = (SV*)POPPTR(ss,ix);
7430 TOPPTR(nss,ix) = sv_dup_inc(sv);
7431 hv = (HV*)POPPTR(ss,ix);
7432 TOPPTR(nss,ix) = hv_dup_inc(hv);
7435 ptr = POPPTR(ss,ix);
7436 TOPPTR(nss,ix) = ptr;
7443 av = (AV*)POPPTR(ss,ix);
7444 TOPPTR(nss,ix) = av_dup(av);
7447 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7459 perl_clone(PerlInterpreter *proto_perl, UV flags)
7462 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7465 #ifdef PERL_IMPLICIT_SYS
7466 return perl_clone_using(proto_perl, flags,
7468 proto_perl->IMemShared,
7469 proto_perl->IMemParse,
7479 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7480 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7481 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7482 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7483 struct IPerlDir* ipD, struct IPerlSock* ipS,
7484 struct IPerlProc* ipP)
7486 /* XXX many of the string copies here can be optimized if they're
7487 * constants; they need to be allocated as common memory and just
7488 * their pointers copied. */
7492 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7494 PERL_SET_THX(pPerl);
7495 # else /* !PERL_OBJECT */
7496 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7497 PERL_SET_THX(my_perl);
7500 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7505 # else /* !DEBUGGING */
7506 Zero(my_perl, 1, PerlInterpreter);
7507 # endif /* DEBUGGING */
7511 PL_MemShared = ipMS;
7519 # endif /* PERL_OBJECT */
7520 #else /* !PERL_IMPLICIT_SYS */
7522 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7523 PERL_SET_THX(my_perl);
7526 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7531 # else /* !DEBUGGING */
7532 Zero(my_perl, 1, PerlInterpreter);
7533 # endif /* DEBUGGING */
7534 #endif /* PERL_IMPLICIT_SYS */
7537 PL_xiv_arenaroot = NULL;
7539 PL_xnv_arenaroot = NULL;
7541 PL_xrv_arenaroot = NULL;
7543 PL_xpv_arenaroot = NULL;
7545 PL_xpviv_arenaroot = NULL;
7546 PL_xpviv_root = NULL;
7547 PL_xpvnv_arenaroot = NULL;
7548 PL_xpvnv_root = NULL;
7549 PL_xpvcv_arenaroot = NULL;
7550 PL_xpvcv_root = NULL;
7551 PL_xpvav_arenaroot = NULL;
7552 PL_xpvav_root = NULL;
7553 PL_xpvhv_arenaroot = NULL;
7554 PL_xpvhv_root = NULL;
7555 PL_xpvmg_arenaroot = NULL;
7556 PL_xpvmg_root = NULL;
7557 PL_xpvlv_arenaroot = NULL;
7558 PL_xpvlv_root = NULL;
7559 PL_xpvbm_arenaroot = NULL;
7560 PL_xpvbm_root = NULL;
7561 PL_he_arenaroot = NULL;
7563 PL_nice_chunk = NULL;
7564 PL_nice_chunk_size = 0;
7567 PL_sv_root = Nullsv;
7568 PL_sv_arenaroot = Nullsv;
7570 PL_debug = proto_perl->Idebug;
7572 /* create SV map for pointer relocation */
7573 PL_ptr_table = ptr_table_new();
7575 /* initialize these special pointers as early as possible */
7576 SvANY(&PL_sv_undef) = NULL;
7577 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7578 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7579 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7582 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7584 SvANY(&PL_sv_no) = new_XPVNV();
7586 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7587 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7588 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7589 SvCUR(&PL_sv_no) = 0;
7590 SvLEN(&PL_sv_no) = 1;
7591 SvNVX(&PL_sv_no) = 0;
7592 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7595 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7597 SvANY(&PL_sv_yes) = new_XPVNV();
7599 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7600 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7601 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7602 SvCUR(&PL_sv_yes) = 1;
7603 SvLEN(&PL_sv_yes) = 2;
7604 SvNVX(&PL_sv_yes) = 1;
7605 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7607 /* create shared string table */
7608 PL_strtab = newHV();
7609 HvSHAREKEYS_off(PL_strtab);
7610 hv_ksplit(PL_strtab, 512);
7611 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7613 PL_compiling = proto_perl->Icompiling;
7614 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7615 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7616 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7617 if (!specialWARN(PL_compiling.cop_warnings))
7618 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7619 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7621 /* pseudo environmental stuff */
7622 PL_origargc = proto_perl->Iorigargc;
7624 New(0, PL_origargv, i+1, char*);
7625 PL_origargv[i] = '\0';
7627 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7629 PL_envgv = gv_dup(proto_perl->Ienvgv);
7630 PL_incgv = gv_dup(proto_perl->Iincgv);
7631 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7632 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7633 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7634 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7637 PL_minus_c = proto_perl->Iminus_c;
7638 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7639 PL_localpatches = proto_perl->Ilocalpatches;
7640 PL_splitstr = proto_perl->Isplitstr;
7641 PL_preprocess = proto_perl->Ipreprocess;
7642 PL_minus_n = proto_perl->Iminus_n;
7643 PL_minus_p = proto_perl->Iminus_p;
7644 PL_minus_l = proto_perl->Iminus_l;
7645 PL_minus_a = proto_perl->Iminus_a;
7646 PL_minus_F = proto_perl->Iminus_F;
7647 PL_doswitches = proto_perl->Idoswitches;
7648 PL_dowarn = proto_perl->Idowarn;
7649 PL_doextract = proto_perl->Idoextract;
7650 PL_sawampersand = proto_perl->Isawampersand;
7651 PL_unsafe = proto_perl->Iunsafe;
7652 PL_inplace = SAVEPV(proto_perl->Iinplace);
7653 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7654 PL_perldb = proto_perl->Iperldb;
7655 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7657 /* magical thingies */
7658 /* XXX time(&PL_basetime) when asked for? */
7659 PL_basetime = proto_perl->Ibasetime;
7660 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7662 PL_maxsysfd = proto_perl->Imaxsysfd;
7663 PL_multiline = proto_perl->Imultiline;
7664 PL_statusvalue = proto_perl->Istatusvalue;
7666 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7669 /* shortcuts to various I/O objects */
7670 PL_stdingv = gv_dup(proto_perl->Istdingv);
7671 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7672 PL_defgv = gv_dup(proto_perl->Idefgv);
7673 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7674 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7675 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7677 /* shortcuts to regexp stuff */
7678 PL_replgv = gv_dup(proto_perl->Ireplgv);
7680 /* shortcuts to misc objects */
7681 PL_errgv = gv_dup(proto_perl->Ierrgv);
7683 /* shortcuts to debugging objects */
7684 PL_DBgv = gv_dup(proto_perl->IDBgv);
7685 PL_DBline = gv_dup(proto_perl->IDBline);
7686 PL_DBsub = gv_dup(proto_perl->IDBsub);
7687 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7688 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7689 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7690 PL_lineary = av_dup(proto_perl->Ilineary);
7691 PL_dbargs = av_dup(proto_perl->Idbargs);
7694 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7695 PL_curstash = hv_dup(proto_perl->Tcurstash);
7696 PL_debstash = hv_dup(proto_perl->Idebstash);
7697 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7698 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7700 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7701 PL_endav = av_dup_inc(proto_perl->Iendav);
7702 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7703 PL_initav = av_dup_inc(proto_perl->Iinitav);
7705 PL_sub_generation = proto_perl->Isub_generation;
7707 /* funky return mechanisms */
7708 PL_forkprocess = proto_perl->Iforkprocess;
7710 /* subprocess state */
7711 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7713 /* internal state */
7714 PL_tainting = proto_perl->Itainting;
7715 PL_maxo = proto_perl->Imaxo;
7716 if (proto_perl->Iop_mask)
7717 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7719 PL_op_mask = Nullch;
7721 /* current interpreter roots */
7722 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7723 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7724 PL_main_start = proto_perl->Imain_start;
7725 PL_eval_root = proto_perl->Ieval_root;
7726 PL_eval_start = proto_perl->Ieval_start;
7728 /* runtime control stuff */
7729 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7730 PL_copline = proto_perl->Icopline;
7732 PL_filemode = proto_perl->Ifilemode;
7733 PL_lastfd = proto_perl->Ilastfd;
7734 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7737 PL_gensym = proto_perl->Igensym;
7738 PL_preambled = proto_perl->Ipreambled;
7739 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7740 PL_laststatval = proto_perl->Ilaststatval;
7741 PL_laststype = proto_perl->Ilaststype;
7742 PL_mess_sv = Nullsv;
7744 PL_orslen = proto_perl->Iorslen;
7745 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7746 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7748 /* interpreter atexit processing */
7749 PL_exitlistlen = proto_perl->Iexitlistlen;
7750 if (PL_exitlistlen) {
7751 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7752 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7755 PL_exitlist = (PerlExitListEntry*)NULL;
7756 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7758 PL_profiledata = NULL;
7759 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7760 /* PL_rsfp_filters entries have fake IoDIRP() */
7761 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7763 PL_compcv = cv_dup(proto_perl->Icompcv);
7764 PL_comppad = av_dup(proto_perl->Icomppad);
7765 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7766 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7767 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7768 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7769 proto_perl->Tcurpad);
7771 #ifdef HAVE_INTERP_INTERN
7772 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7775 /* more statics moved here */
7776 PL_generation = proto_perl->Igeneration;
7777 PL_DBcv = cv_dup(proto_perl->IDBcv);
7779 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7780 PL_in_clean_all = proto_perl->Iin_clean_all;
7782 PL_uid = proto_perl->Iuid;
7783 PL_euid = proto_perl->Ieuid;
7784 PL_gid = proto_perl->Igid;
7785 PL_egid = proto_perl->Iegid;
7786 PL_nomemok = proto_perl->Inomemok;
7787 PL_an = proto_perl->Ian;
7788 PL_cop_seqmax = proto_perl->Icop_seqmax;
7789 PL_op_seqmax = proto_perl->Iop_seqmax;
7790 PL_evalseq = proto_perl->Ievalseq;
7791 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7792 PL_origalen = proto_perl->Iorigalen;
7793 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7794 PL_osname = SAVEPV(proto_perl->Iosname);
7795 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7796 PL_sighandlerp = proto_perl->Isighandlerp;
7799 PL_runops = proto_perl->Irunops;
7801 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7804 PL_cshlen = proto_perl->Icshlen;
7805 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7808 PL_lex_state = proto_perl->Ilex_state;
7809 PL_lex_defer = proto_perl->Ilex_defer;
7810 PL_lex_expect = proto_perl->Ilex_expect;
7811 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7812 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7813 PL_lex_starts = proto_perl->Ilex_starts;
7814 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7815 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7816 PL_lex_op = proto_perl->Ilex_op;
7817 PL_lex_inpat = proto_perl->Ilex_inpat;
7818 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7819 PL_lex_brackets = proto_perl->Ilex_brackets;
7820 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7821 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7822 PL_lex_casemods = proto_perl->Ilex_casemods;
7823 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7824 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7826 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7827 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7828 PL_nexttoke = proto_perl->Inexttoke;
7830 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7831 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7832 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7833 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7834 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7835 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7836 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7837 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7838 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7839 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7840 PL_pending_ident = proto_perl->Ipending_ident;
7841 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7843 PL_expect = proto_perl->Iexpect;
7845 PL_multi_start = proto_perl->Imulti_start;
7846 PL_multi_end = proto_perl->Imulti_end;
7847 PL_multi_open = proto_perl->Imulti_open;
7848 PL_multi_close = proto_perl->Imulti_close;
7850 PL_error_count = proto_perl->Ierror_count;
7851 PL_subline = proto_perl->Isubline;
7852 PL_subname = sv_dup_inc(proto_perl->Isubname);
7854 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7855 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7856 PL_padix = proto_perl->Ipadix;
7857 PL_padix_floor = proto_perl->Ipadix_floor;
7858 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7860 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7861 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7862 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7863 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7864 PL_last_lop_op = proto_perl->Ilast_lop_op;
7865 PL_in_my = proto_perl->Iin_my;
7866 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
7868 PL_cryptseen = proto_perl->Icryptseen;
7871 PL_hints = proto_perl->Ihints;
7873 PL_amagic_generation = proto_perl->Iamagic_generation;
7875 #ifdef USE_LOCALE_COLLATE
7876 PL_collation_ix = proto_perl->Icollation_ix;
7877 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
7878 PL_collation_standard = proto_perl->Icollation_standard;
7879 PL_collxfrm_base = proto_perl->Icollxfrm_base;
7880 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
7881 #endif /* USE_LOCALE_COLLATE */
7883 #ifdef USE_LOCALE_NUMERIC
7884 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
7885 PL_numeric_standard = proto_perl->Inumeric_standard;
7886 PL_numeric_local = proto_perl->Inumeric_local;
7887 PL_numeric_radix = proto_perl->Inumeric_radix;
7888 #endif /* !USE_LOCALE_NUMERIC */
7890 /* utf8 character classes */
7891 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
7892 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
7893 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
7894 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
7895 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
7896 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
7897 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
7898 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
7899 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
7900 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
7901 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
7902 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
7903 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
7904 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
7905 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
7906 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
7907 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
7910 PL_last_swash_hv = Nullhv; /* reinits on demand */
7911 PL_last_swash_klen = 0;
7912 PL_last_swash_key[0]= '\0';
7913 PL_last_swash_tmps = (U8*)NULL;
7914 PL_last_swash_slen = 0;
7916 /* perly.c globals */
7917 PL_yydebug = proto_perl->Iyydebug;
7918 PL_yynerrs = proto_perl->Iyynerrs;
7919 PL_yyerrflag = proto_perl->Iyyerrflag;
7920 PL_yychar = proto_perl->Iyychar;
7921 PL_yyval = proto_perl->Iyyval;
7922 PL_yylval = proto_perl->Iyylval;
7924 PL_glob_index = proto_perl->Iglob_index;
7925 PL_srand_called = proto_perl->Isrand_called;
7926 PL_uudmap['M'] = 0; /* reinits on demand */
7927 PL_bitcount = Nullch; /* reinits on demand */
7929 if (proto_perl->Ipsig_ptr) {
7930 int sig_num[] = { SIG_NUM };
7931 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
7932 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
7933 for (i = 1; PL_sig_name[i]; i++) {
7934 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
7935 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
7939 PL_psig_ptr = (SV**)NULL;
7940 PL_psig_name = (SV**)NULL;
7943 /* thrdvar.h stuff */
7946 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
7947 PL_tmps_ix = proto_perl->Ttmps_ix;
7948 PL_tmps_max = proto_perl->Ttmps_max;
7949 PL_tmps_floor = proto_perl->Ttmps_floor;
7950 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
7952 while (i <= PL_tmps_ix) {
7953 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
7957 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
7958 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
7959 Newz(54, PL_markstack, i, I32);
7960 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
7961 - proto_perl->Tmarkstack);
7962 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
7963 - proto_perl->Tmarkstack);
7964 Copy(proto_perl->Tmarkstack, PL_markstack,
7965 PL_markstack_ptr - PL_markstack + 1, I32);
7967 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
7968 * NOTE: unlike the others! */
7969 PL_scopestack_ix = proto_perl->Tscopestack_ix;
7970 PL_scopestack_max = proto_perl->Tscopestack_max;
7971 Newz(54, PL_scopestack, PL_scopestack_max, I32);
7972 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
7974 /* next push_return() sets PL_retstack[PL_retstack_ix]
7975 * NOTE: unlike the others! */
7976 PL_retstack_ix = proto_perl->Tretstack_ix;
7977 PL_retstack_max = proto_perl->Tretstack_max;
7978 Newz(54, PL_retstack, PL_retstack_max, OP*);
7979 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
7981 /* NOTE: si_dup() looks at PL_markstack */
7982 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
7984 /* PL_curstack = PL_curstackinfo->si_stack; */
7985 PL_curstack = av_dup(proto_perl->Tcurstack);
7986 PL_mainstack = av_dup(proto_perl->Tmainstack);
7988 /* next PUSHs() etc. set *(PL_stack_sp+1) */
7989 PL_stack_base = AvARRAY(PL_curstack);
7990 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
7991 - proto_perl->Tstack_base);
7992 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
7994 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
7995 * NOTE: unlike the others! */
7996 PL_savestack_ix = proto_perl->Tsavestack_ix;
7997 PL_savestack_max = proto_perl->Tsavestack_max;
7998 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
7999 PL_savestack = ss_dup(proto_perl);
8003 ENTER; /* perl_destruct() wants to LEAVE; */
8006 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8007 PL_top_env = &PL_start_env;
8009 PL_op = proto_perl->Top;
8012 PL_Xpv = (XPV*)NULL;
8013 PL_na = proto_perl->Tna;
8015 PL_statbuf = proto_perl->Tstatbuf;
8016 PL_statcache = proto_perl->Tstatcache;
8017 PL_statgv = gv_dup(proto_perl->Tstatgv);
8018 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8020 PL_timesbuf = proto_perl->Ttimesbuf;
8023 PL_tainted = proto_perl->Ttainted;
8024 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8025 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8026 PL_rs = sv_dup_inc(proto_perl->Trs);
8027 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8028 PL_ofslen = proto_perl->Tofslen;
8029 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8030 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8031 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8032 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8033 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8034 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8036 PL_restartop = proto_perl->Trestartop;
8037 PL_in_eval = proto_perl->Tin_eval;
8038 PL_delaymagic = proto_perl->Tdelaymagic;
8039 PL_dirty = proto_perl->Tdirty;
8040 PL_localizing = proto_perl->Tlocalizing;
8042 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8043 PL_protect = proto_perl->Tprotect;
8045 PL_errors = sv_dup_inc(proto_perl->Terrors);
8046 PL_av_fetch_sv = Nullsv;
8047 PL_hv_fetch_sv = Nullsv;
8048 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8049 PL_modcount = proto_perl->Tmodcount;
8050 PL_lastgotoprobe = Nullop;
8051 PL_dumpindent = proto_perl->Tdumpindent;
8053 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8054 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8055 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8056 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8057 PL_sortcxix = proto_perl->Tsortcxix;
8058 PL_efloatbuf = Nullch; /* reinits on demand */
8059 PL_efloatsize = 0; /* reinits on demand */
8063 PL_screamfirst = NULL;
8064 PL_screamnext = NULL;
8065 PL_maxscream = -1; /* reinits on demand */
8066 PL_lastscream = Nullsv;
8068 PL_watchaddr = NULL;
8069 PL_watchok = Nullch;
8071 PL_regdummy = proto_perl->Tregdummy;
8072 PL_regcomp_parse = Nullch;
8073 PL_regxend = Nullch;
8074 PL_regcode = (regnode*)NULL;
8077 PL_regprecomp = Nullch;
8082 PL_seen_zerolen = 0;
8084 PL_regcomp_rx = (regexp*)NULL;
8086 PL_colorset = 0; /* reinits PL_colors[] */
8087 /*PL_colors[6] = {0,0,0,0,0,0};*/
8088 PL_reg_whilem_seen = 0;
8089 PL_reginput = Nullch;
8092 PL_regstartp = (I32*)NULL;
8093 PL_regendp = (I32*)NULL;
8094 PL_reglastparen = (U32*)NULL;
8095 PL_regtill = Nullch;
8097 PL_reg_start_tmp = (char**)NULL;
8098 PL_reg_start_tmpl = 0;
8099 PL_regdata = (struct reg_data*)NULL;
8102 PL_reg_eval_set = 0;
8104 PL_regprogram = (regnode*)NULL;
8106 PL_regcc = (CURCUR*)NULL;
8107 PL_reg_call_cc = (struct re_cc_state*)NULL;
8108 PL_reg_re = (regexp*)NULL;
8109 PL_reg_ganch = Nullch;
8111 PL_reg_magic = (MAGIC*)NULL;
8113 PL_reg_oldcurpm = (PMOP*)NULL;
8114 PL_reg_curpm = (PMOP*)NULL;
8115 PL_reg_oldsaved = Nullch;
8116 PL_reg_oldsavedlen = 0;
8118 PL_reg_leftiter = 0;
8119 PL_reg_poscache = Nullch;
8120 PL_reg_poscache_size= 0;
8122 /* RE engine - function pointers */
8123 PL_regcompp = proto_perl->Tregcompp;
8124 PL_regexecp = proto_perl->Tregexecp;
8125 PL_regint_start = proto_perl->Tregint_start;
8126 PL_regint_string = proto_perl->Tregint_string;
8127 PL_regfree = proto_perl->Tregfree;
8129 PL_reginterp_cnt = 0;
8130 PL_reg_starttry = 0;
8133 return (PerlInterpreter*)pPerl;
8139 #else /* !USE_ITHREADS */
8145 #endif /* USE_ITHREADS */
8148 do_report_used(pTHXo_ SV *sv)
8150 if (SvTYPE(sv) != SVTYPEMASK) {
8151 PerlIO_printf(Perl_debug_log, "****\n");
8157 do_clean_objs(pTHXo_ SV *sv)
8161 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8162 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8168 /* XXX Might want to check arrays, etc. */
8171 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8173 do_clean_named_objs(pTHXo_ SV *sv)
8175 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8176 if ( SvOBJECT(GvSV(sv)) ||
8177 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8178 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8179 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8180 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8182 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8190 do_clean_all(pTHXo_ SV *sv)
8192 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8193 SvFLAGS(sv) |= SVf_BREAK;