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 =for apidoc sv_utf8_upgrade
2396 Convert the PV of an SV to its UTF8-encoded form.
2402 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2407 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2410 /* This function could be much more efficient if we had a FLAG
2411 * to signal if there are any hibit chars in the string
2414 for (c = SvPVX(sv); c < SvEND(sv); c++) {
2421 SvGROW(sv, SvCUR(sv) + hicount + 1);
2423 src = SvEND(sv) - 1;
2424 SvCUR_set(sv, SvCUR(sv) + hicount);
2425 dst = SvEND(sv) - 1;
2430 uv_to_utf8((U8*)dst, (U8)*src--);
2443 =for apidoc sv_utf8_downgrade
2445 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2446 This may not be possible if the PV contains non-byte encoding characters;
2447 if this is the case, either returns false or, if C<fail_ok> is not
2454 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2456 if (SvPOK(sv) && SvUTF8(sv)) {
2457 char *c = SvPVX(sv);
2459 /* need to figure out if this is possible at all first */
2460 while (c < SvEND(sv)) {
2463 UV uv = utf8_to_uv((U8*)c, &len);
2468 /* XXX might want to make a callback here instead */
2469 Perl_croak(aTHX_ "Big byte");
2482 char *src = first_hi;
2483 char *dst = first_hi;
2484 while (src < SvEND(sv)) {
2487 U8 u = (U8)utf8_to_uv((U8*)src, &len);
2495 SvCUR_set(sv, dst - SvPVX(sv));
2503 =for apidoc sv_utf8_encode
2505 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2506 flag so that it looks like bytes again. Nothing calls this.
2512 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2514 sv_utf8_upgrade(sv);
2519 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2523 bool has_utf = FALSE;
2524 if (!sv_utf8_downgrade(sv, TRUE))
2527 /* it is actually just a matter of turning the utf8 flag on, but
2528 * we want to make sure everything inside is valid utf8 first.
2531 while (c < SvEND(sv)) {
2534 (void)utf8_to_uv((U8*)c, &len);
2554 /* Note: sv_setsv() should not be called with a source string that needs
2555 * to be reused, since it may destroy the source string if it is marked
2560 =for apidoc sv_setsv
2562 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2563 The source SV may be destroyed if it is mortal. Does not handle 'set'
2564 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2571 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2574 register U32 sflags;
2580 SV_CHECK_THINKFIRST(dstr);
2582 sstr = &PL_sv_undef;
2583 stype = SvTYPE(sstr);
2584 dtype = SvTYPE(dstr);
2588 /* There's a lot of redundancy below but we're going for speed here */
2593 if (dtype != SVt_PVGV) {
2594 (void)SvOK_off(dstr);
2602 sv_upgrade(dstr, SVt_IV);
2605 sv_upgrade(dstr, SVt_PVNV);
2609 sv_upgrade(dstr, SVt_PVIV);
2612 (void)SvIOK_only(dstr);
2613 SvIVX(dstr) = SvIVX(sstr);
2626 sv_upgrade(dstr, SVt_NV);
2631 sv_upgrade(dstr, SVt_PVNV);
2634 SvNVX(dstr) = SvNVX(sstr);
2635 (void)SvNOK_only(dstr);
2643 sv_upgrade(dstr, SVt_RV);
2644 else if (dtype == SVt_PVGV &&
2645 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2648 if (GvIMPORTED(dstr) != GVf_IMPORTED
2649 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2651 GvIMPORTED_on(dstr);
2662 sv_upgrade(dstr, SVt_PV);
2665 if (dtype < SVt_PVIV)
2666 sv_upgrade(dstr, SVt_PVIV);
2669 if (dtype < SVt_PVNV)
2670 sv_upgrade(dstr, SVt_PVNV);
2677 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2678 PL_op_name[PL_op->op_type]);
2680 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2684 if (dtype <= SVt_PVGV) {
2686 if (dtype != SVt_PVGV) {
2687 char *name = GvNAME(sstr);
2688 STRLEN len = GvNAMELEN(sstr);
2689 sv_upgrade(dstr, SVt_PVGV);
2690 sv_magic(dstr, dstr, '*', Nullch, 0);
2691 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2692 GvNAME(dstr) = savepvn(name, len);
2693 GvNAMELEN(dstr) = len;
2694 SvFAKE_on(dstr); /* can coerce to non-glob */
2696 /* ahem, death to those who redefine active sort subs */
2697 else if (PL_curstackinfo->si_type == PERLSI_SORT
2698 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2699 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2701 (void)SvOK_off(dstr);
2702 GvINTRO_off(dstr); /* one-shot flag */
2704 GvGP(dstr) = gp_ref(GvGP(sstr));
2706 if (GvIMPORTED(dstr) != GVf_IMPORTED
2707 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2709 GvIMPORTED_on(dstr);
2717 if (SvGMAGICAL(sstr)) {
2719 if (SvTYPE(sstr) != stype) {
2720 stype = SvTYPE(sstr);
2721 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2725 if (stype == SVt_PVLV)
2726 (void)SvUPGRADE(dstr, SVt_PVNV);
2728 (void)SvUPGRADE(dstr, stype);
2731 sflags = SvFLAGS(sstr);
2733 if (sflags & SVf_ROK) {
2734 if (dtype >= SVt_PV) {
2735 if (dtype == SVt_PVGV) {
2736 SV *sref = SvREFCNT_inc(SvRV(sstr));
2738 int intro = GvINTRO(dstr);
2743 GvINTRO_off(dstr); /* one-shot flag */
2744 Newz(602,gp, 1, GP);
2745 GvGP(dstr) = gp_ref(gp);
2746 GvSV(dstr) = NEWSV(72,0);
2747 GvLINE(dstr) = CopLINE(PL_curcop);
2748 GvEGV(dstr) = (GV*)dstr;
2751 switch (SvTYPE(sref)) {
2754 SAVESPTR(GvAV(dstr));
2756 dref = (SV*)GvAV(dstr);
2757 GvAV(dstr) = (AV*)sref;
2758 if (!GvIMPORTED_AV(dstr)
2759 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2761 GvIMPORTED_AV_on(dstr);
2766 SAVESPTR(GvHV(dstr));
2768 dref = (SV*)GvHV(dstr);
2769 GvHV(dstr) = (HV*)sref;
2770 if (!GvIMPORTED_HV(dstr)
2771 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2773 GvIMPORTED_HV_on(dstr);
2778 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2779 SvREFCNT_dec(GvCV(dstr));
2780 GvCV(dstr) = Nullcv;
2781 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2782 PL_sub_generation++;
2784 SAVESPTR(GvCV(dstr));
2787 dref = (SV*)GvCV(dstr);
2788 if (GvCV(dstr) != (CV*)sref) {
2789 CV* cv = GvCV(dstr);
2791 if (!GvCVGEN((GV*)dstr) &&
2792 (CvROOT(cv) || CvXSUB(cv)))
2794 SV *const_sv = cv_const_sv(cv);
2795 bool const_changed = TRUE;
2797 const_changed = sv_cmp(const_sv,
2798 op_const_sv(CvSTART((CV*)sref),
2800 /* ahem, death to those who redefine
2801 * active sort subs */
2802 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2803 PL_sortcop == CvSTART(cv))
2805 "Can't redefine active sort subroutine %s",
2806 GvENAME((GV*)dstr));
2807 if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE))
2808 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2809 "Constant subroutine %s redefined"
2810 : "Subroutine %s redefined",
2811 GvENAME((GV*)dstr));
2813 cv_ckproto(cv, (GV*)dstr,
2814 SvPOK(sref) ? SvPVX(sref) : Nullch);
2816 GvCV(dstr) = (CV*)sref;
2817 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2818 GvASSUMECV_on(dstr);
2819 PL_sub_generation++;
2821 if (!GvIMPORTED_CV(dstr)
2822 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2824 GvIMPORTED_CV_on(dstr);
2829 SAVESPTR(GvIOp(dstr));
2831 dref = (SV*)GvIOp(dstr);
2832 GvIOp(dstr) = (IO*)sref;
2836 SAVESPTR(GvFORM(dstr));
2838 dref = (SV*)GvFORM(dstr);
2839 GvFORM(dstr) = (CV*)sref;
2843 SAVESPTR(GvSV(dstr));
2845 dref = (SV*)GvSV(dstr);
2847 if (!GvIMPORTED_SV(dstr)
2848 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2850 GvIMPORTED_SV_on(dstr);
2862 (void)SvOOK_off(dstr); /* backoff */
2864 Safefree(SvPVX(dstr));
2865 SvLEN(dstr)=SvCUR(dstr)=0;
2868 (void)SvOK_off(dstr);
2869 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2871 if (sflags & SVp_NOK) {
2873 SvNVX(dstr) = SvNVX(sstr);
2875 if (sflags & SVp_IOK) {
2876 (void)SvIOK_on(dstr);
2877 SvIVX(dstr) = SvIVX(sstr);
2878 if (sflags & SVf_IVisUV)
2881 if (SvAMAGIC(sstr)) {
2885 else if (sflags & SVp_POK) {
2888 * Check to see if we can just swipe the string. If so, it's a
2889 * possible small lose on short strings, but a big win on long ones.
2890 * It might even be a win on short strings if SvPVX(dstr)
2891 * has to be allocated and SvPVX(sstr) has to be freed.
2894 if (SvTEMP(sstr) && /* slated for free anyway? */
2895 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2896 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2898 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2900 SvFLAGS(dstr) &= ~SVf_OOK;
2901 Safefree(SvPVX(dstr) - SvIVX(dstr));
2903 else if (SvLEN(dstr))
2904 Safefree(SvPVX(dstr));
2906 (void)SvPOK_only(dstr);
2907 SvPV_set(dstr, SvPVX(sstr));
2908 SvLEN_set(dstr, SvLEN(sstr));
2909 SvCUR_set(dstr, SvCUR(sstr));
2912 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
2913 SvPV_set(sstr, Nullch);
2918 else { /* have to copy actual string */
2919 STRLEN len = SvCUR(sstr);
2921 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2922 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2923 SvCUR_set(dstr, len);
2924 *SvEND(dstr) = '\0';
2925 (void)SvPOK_only(dstr);
2927 if ((sflags & SVf_UTF8) && !IN_BYTE)
2930 if (sflags & SVp_NOK) {
2932 SvNVX(dstr) = SvNVX(sstr);
2934 if (sflags & SVp_IOK) {
2935 (void)SvIOK_on(dstr);
2936 SvIVX(dstr) = SvIVX(sstr);
2937 if (sflags & SVf_IVisUV)
2941 else if (sflags & SVp_NOK) {
2942 SvNVX(dstr) = SvNVX(sstr);
2943 (void)SvNOK_only(dstr);
2944 if (sflags & SVf_IOK) {
2945 (void)SvIOK_on(dstr);
2946 SvIVX(dstr) = SvIVX(sstr);
2947 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2948 if (sflags & SVf_IVisUV)
2952 else if (sflags & SVp_IOK) {
2953 (void)SvIOK_only(dstr);
2954 SvIVX(dstr) = SvIVX(sstr);
2955 if (sflags & SVf_IVisUV)
2959 if (dtype == SVt_PVGV) {
2960 if (ckWARN(WARN_MISC))
2961 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2964 (void)SvOK_off(dstr);
2970 =for apidoc sv_setsv_mg
2972 Like C<sv_setsv>, but also handles 'set' magic.
2978 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2980 sv_setsv(dstr,sstr);
2985 =for apidoc sv_setpvn
2987 Copies a string into an SV. The C<len> parameter indicates the number of
2988 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2994 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2996 register char *dptr;
2997 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2998 elicit a warning, but it won't hurt. */
2999 SV_CHECK_THINKFIRST(sv);
3004 (void)SvUPGRADE(sv, SVt_PV);
3006 SvGROW(sv, len + 1);
3008 Move(ptr,dptr,len,char);
3011 (void)SvPOK_only(sv); /* validate pointer */
3016 =for apidoc sv_setpvn_mg
3018 Like C<sv_setpvn>, but also handles 'set' magic.
3024 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3026 sv_setpvn(sv,ptr,len);
3031 =for apidoc sv_setpv
3033 Copies a string into an SV. The string must be null-terminated. Does not
3034 handle 'set' magic. See C<sv_setpv_mg>.
3040 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3042 register STRLEN len;
3044 SV_CHECK_THINKFIRST(sv);
3050 (void)SvUPGRADE(sv, SVt_PV);
3052 SvGROW(sv, len + 1);
3053 Move(ptr,SvPVX(sv),len+1,char);
3055 (void)SvPOK_only(sv); /* validate pointer */
3060 =for apidoc sv_setpv_mg
3062 Like C<sv_setpv>, but also handles 'set' magic.
3068 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3075 =for apidoc sv_usepvn
3077 Tells an SV to use C<ptr> to find its string value. Normally the string is
3078 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3079 The C<ptr> should point to memory that was allocated by C<malloc>. The
3080 string length, C<len>, must be supplied. This function will realloc the
3081 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3082 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3083 See C<sv_usepvn_mg>.
3089 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3091 SV_CHECK_THINKFIRST(sv);
3092 (void)SvUPGRADE(sv, SVt_PV);
3097 (void)SvOOK_off(sv);
3098 if (SvPVX(sv) && SvLEN(sv))
3099 Safefree(SvPVX(sv));
3100 Renew(ptr, len+1, char);
3103 SvLEN_set(sv, len+1);
3105 (void)SvPOK_only(sv); /* validate pointer */
3110 =for apidoc sv_usepvn_mg
3112 Like C<sv_usepvn>, but also handles 'set' magic.
3118 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3120 sv_usepvn(sv,ptr,len);
3125 Perl_sv_force_normal(pTHX_ register SV *sv)
3127 if (SvREADONLY(sv)) {
3129 if (PL_curcop != &PL_compiling)
3130 Perl_croak(aTHX_ PL_no_modify);
3134 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3141 Efficient removal of characters from the beginning of the string buffer.
3142 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3143 the string buffer. The C<ptr> becomes the first character of the adjusted
3150 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3154 register STRLEN delta;
3156 if (!ptr || !SvPOKp(sv))
3158 SV_CHECK_THINKFIRST(sv);
3159 if (SvTYPE(sv) < SVt_PVIV)
3160 sv_upgrade(sv,SVt_PVIV);
3163 if (!SvLEN(sv)) { /* make copy of shared string */
3164 char *pvx = SvPVX(sv);
3165 STRLEN len = SvCUR(sv);
3166 SvGROW(sv, len + 1);
3167 Move(pvx,SvPVX(sv),len,char);
3171 SvFLAGS(sv) |= SVf_OOK;
3173 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3174 delta = ptr - SvPVX(sv);
3182 =for apidoc sv_catpvn
3184 Concatenates the string onto the end of the string which is in the SV. The
3185 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3186 'set' magic. See C<sv_catpvn_mg>.
3192 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3197 junk = SvPV_force(sv, tlen);
3198 SvGROW(sv, tlen + len + 1);
3201 Move(ptr,SvPVX(sv)+tlen,len,char);
3204 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3209 =for apidoc sv_catpvn_mg
3211 Like C<sv_catpvn>, but also handles 'set' magic.
3217 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3219 sv_catpvn(sv,ptr,len);
3224 =for apidoc sv_catsv
3226 Concatenates the string from SV C<ssv> onto the end of the string in SV
3227 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3233 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3239 if ((s = SvPV(sstr, len))) {
3240 if (DO_UTF8(sstr)) {
3241 sv_utf8_upgrade(dstr);
3242 sv_catpvn(dstr,s,len);
3246 sv_catpvn(dstr,s,len);
3251 =for apidoc sv_catsv_mg
3253 Like C<sv_catsv>, but also handles 'set' magic.
3259 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3261 sv_catsv(dstr,sstr);
3266 =for apidoc sv_catpv
3268 Concatenates the string onto the end of the string which is in the SV.
3269 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3275 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3277 register STRLEN len;
3283 junk = SvPV_force(sv, tlen);
3285 SvGROW(sv, tlen + len + 1);
3288 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3290 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3295 =for apidoc sv_catpv_mg
3297 Like C<sv_catpv>, but also handles 'set' magic.
3303 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3310 Perl_newSV(pTHX_ STRLEN len)
3316 sv_upgrade(sv, SVt_PV);
3317 SvGROW(sv, len + 1);
3322 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3325 =for apidoc sv_magic
3327 Adds magic to an SV.
3333 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3337 if (SvREADONLY(sv)) {
3339 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3340 Perl_croak(aTHX_ PL_no_modify);
3342 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3343 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3350 (void)SvUPGRADE(sv, SVt_PVMG);
3352 Newz(702,mg, 1, MAGIC);
3353 mg->mg_moremagic = SvMAGIC(sv);
3356 if (!obj || obj == sv || how == '#' || how == 'r')
3360 mg->mg_obj = SvREFCNT_inc(obj);
3361 mg->mg_flags |= MGf_REFCOUNTED;
3364 mg->mg_len = namlen;
3367 mg->mg_ptr = savepvn(name, namlen);
3368 else if (namlen == HEf_SVKEY)
3369 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3373 mg->mg_virtual = &PL_vtbl_sv;
3376 mg->mg_virtual = &PL_vtbl_amagic;
3379 mg->mg_virtual = &PL_vtbl_amagicelem;
3385 mg->mg_virtual = &PL_vtbl_bm;
3388 mg->mg_virtual = &PL_vtbl_regdata;
3391 mg->mg_virtual = &PL_vtbl_regdatum;
3394 mg->mg_virtual = &PL_vtbl_env;
3397 mg->mg_virtual = &PL_vtbl_fm;
3400 mg->mg_virtual = &PL_vtbl_envelem;
3403 mg->mg_virtual = &PL_vtbl_mglob;
3406 mg->mg_virtual = &PL_vtbl_isa;
3409 mg->mg_virtual = &PL_vtbl_isaelem;
3412 mg->mg_virtual = &PL_vtbl_nkeys;
3419 mg->mg_virtual = &PL_vtbl_dbline;
3423 mg->mg_virtual = &PL_vtbl_mutex;
3425 #endif /* USE_THREADS */
3426 #ifdef USE_LOCALE_COLLATE
3428 mg->mg_virtual = &PL_vtbl_collxfrm;
3430 #endif /* USE_LOCALE_COLLATE */
3432 mg->mg_virtual = &PL_vtbl_pack;
3436 mg->mg_virtual = &PL_vtbl_packelem;
3439 mg->mg_virtual = &PL_vtbl_regexp;
3442 mg->mg_virtual = &PL_vtbl_sig;
3445 mg->mg_virtual = &PL_vtbl_sigelem;
3448 mg->mg_virtual = &PL_vtbl_taint;
3452 mg->mg_virtual = &PL_vtbl_uvar;
3455 mg->mg_virtual = &PL_vtbl_vec;
3458 mg->mg_virtual = &PL_vtbl_substr;
3461 mg->mg_virtual = &PL_vtbl_defelem;
3464 mg->mg_virtual = &PL_vtbl_glob;
3467 mg->mg_virtual = &PL_vtbl_arylen;
3470 mg->mg_virtual = &PL_vtbl_pos;
3473 mg->mg_virtual = &PL_vtbl_backref;
3475 case '~': /* Reserved for use by extensions not perl internals. */
3476 /* Useful for attaching extension internal data to perl vars. */
3477 /* Note that multiple extensions may clash if magical scalars */
3478 /* etc holding private data from one are passed to another. */
3482 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3486 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3490 =for apidoc sv_unmagic
3492 Removes magic from an SV.
3498 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3502 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3505 for (mg = *mgp; mg; mg = *mgp) {
3506 if (mg->mg_type == type) {
3507 MGVTBL* vtbl = mg->mg_virtual;
3508 *mgp = mg->mg_moremagic;
3509 if (vtbl && vtbl->svt_free)
3510 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3511 if (mg->mg_ptr && mg->mg_type != 'g')
3512 if (mg->mg_len >= 0)
3513 Safefree(mg->mg_ptr);
3514 else if (mg->mg_len == HEf_SVKEY)
3515 SvREFCNT_dec((SV*)mg->mg_ptr);
3516 if (mg->mg_flags & MGf_REFCOUNTED)
3517 SvREFCNT_dec(mg->mg_obj);
3521 mgp = &mg->mg_moremagic;
3525 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3532 =for apidoc sv_rvweaken
3540 Perl_sv_rvweaken(pTHX_ SV *sv)
3543 if (!SvOK(sv)) /* let undefs pass */
3546 Perl_croak(aTHX_ "Can't weaken a nonreference");
3547 else if (SvWEAKREF(sv)) {
3549 if (ckWARN(WARN_MISC))
3550 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3554 sv_add_backref(tsv, sv);
3561 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3565 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3566 av = (AV*)mg->mg_obj;
3569 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3570 SvREFCNT_dec(av); /* for sv_magic */
3576 S_sv_del_backref(pTHX_ SV *sv)
3583 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3584 Perl_croak(aTHX_ "panic: del_backref");
3585 av = (AV *)mg->mg_obj;
3590 svp[i] = &PL_sv_undef; /* XXX */
3597 =for apidoc sv_insert
3599 Inserts a string at the specified offset/length within the SV. Similar to
3600 the Perl substr() function.
3606 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3610 register char *midend;
3611 register char *bigend;
3617 Perl_croak(aTHX_ "Can't modify non-existent substring");
3618 SvPV_force(bigstr, curlen);
3619 (void)SvPOK_only_UTF8(bigstr);
3620 if (offset + len > curlen) {
3621 SvGROW(bigstr, offset+len+1);
3622 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3623 SvCUR_set(bigstr, offset+len);
3627 i = littlelen - len;
3628 if (i > 0) { /* string might grow */
3629 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3630 mid = big + offset + len;
3631 midend = bigend = big + SvCUR(bigstr);
3634 while (midend > mid) /* shove everything down */
3635 *--bigend = *--midend;
3636 Move(little,big+offset,littlelen,char);
3642 Move(little,SvPVX(bigstr)+offset,len,char);
3647 big = SvPVX(bigstr);
3650 bigend = big + SvCUR(bigstr);
3652 if (midend > bigend)
3653 Perl_croak(aTHX_ "panic: sv_insert");
3655 if (mid - big > bigend - midend) { /* faster to shorten from end */
3657 Move(little, mid, littlelen,char);
3660 i = bigend - midend;
3662 Move(midend, mid, i,char);
3666 SvCUR_set(bigstr, mid - big);
3669 else if ((i = mid - big)) { /* faster from front */
3670 midend -= littlelen;
3672 sv_chop(bigstr,midend-i);
3677 Move(little, mid, littlelen,char);
3679 else if (littlelen) {
3680 midend -= littlelen;
3681 sv_chop(bigstr,midend);
3682 Move(little,midend,littlelen,char);
3685 sv_chop(bigstr,midend);
3691 =for apidoc sv_replace
3693 Make the first argument a copy of the second, then delete the original.
3699 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3702 U32 refcnt = SvREFCNT(sv);
3703 SV_CHECK_THINKFIRST(sv);
3704 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3705 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3706 if (SvMAGICAL(sv)) {
3710 sv_upgrade(nsv, SVt_PVMG);
3711 SvMAGIC(nsv) = SvMAGIC(sv);
3712 SvFLAGS(nsv) |= SvMAGICAL(sv);
3718 assert(!SvREFCNT(sv));
3719 StructCopy(nsv,sv,SV);
3720 SvREFCNT(sv) = refcnt;
3721 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3726 =for apidoc sv_clear
3728 Clear an SV, making it empty. Does not free the memory used by the SV
3735 Perl_sv_clear(pTHX_ register SV *sv)
3739 assert(SvREFCNT(sv) == 0);
3743 if (PL_defstash) { /* Still have a symbol table? */
3748 Zero(&tmpref, 1, SV);
3749 sv_upgrade(&tmpref, SVt_RV);
3751 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3752 SvREFCNT(&tmpref) = 1;
3755 stash = SvSTASH(sv);
3756 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3759 PUSHSTACKi(PERLSI_DESTROY);
3760 SvRV(&tmpref) = SvREFCNT_inc(sv);
3765 call_sv((SV*)GvCV(destructor),
3766 G_DISCARD|G_EVAL|G_KEEPERR);
3772 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3774 del_XRV(SvANY(&tmpref));
3777 if (PL_in_clean_objs)
3778 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3780 /* DESTROY gave object new lease on life */
3786 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3787 SvOBJECT_off(sv); /* Curse the object. */
3788 if (SvTYPE(sv) != SVt_PVIO)
3789 --PL_sv_objcount; /* XXX Might want something more general */
3792 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3795 switch (SvTYPE(sv)) {
3798 IoIFP(sv) != PerlIO_stdin() &&
3799 IoIFP(sv) != PerlIO_stdout() &&
3800 IoIFP(sv) != PerlIO_stderr())
3802 io_close((IO*)sv, FALSE);
3804 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3805 PerlDir_close(IoDIRP(sv));
3806 IoDIRP(sv) = (DIR*)NULL;
3807 Safefree(IoTOP_NAME(sv));
3808 Safefree(IoFMT_NAME(sv));
3809 Safefree(IoBOTTOM_NAME(sv));
3824 SvREFCNT_dec(LvTARG(sv));
3828 Safefree(GvNAME(sv));
3829 /* cannot decrease stash refcount yet, as we might recursively delete
3830 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3831 of stash until current sv is completely gone.
3832 -- JohnPC, 27 Mar 1998 */
3833 stash = GvSTASH(sv);
3839 (void)SvOOK_off(sv);
3847 SvREFCNT_dec(SvRV(sv));
3849 else if (SvPVX(sv) && SvLEN(sv))
3850 Safefree(SvPVX(sv));
3860 switch (SvTYPE(sv)) {
3876 del_XPVIV(SvANY(sv));
3879 del_XPVNV(SvANY(sv));
3882 del_XPVMG(SvANY(sv));
3885 del_XPVLV(SvANY(sv));
3888 del_XPVAV(SvANY(sv));
3891 del_XPVHV(SvANY(sv));
3894 del_XPVCV(SvANY(sv));
3897 del_XPVGV(SvANY(sv));
3898 /* code duplication for increased performance. */
3899 SvFLAGS(sv) &= SVf_BREAK;
3900 SvFLAGS(sv) |= SVTYPEMASK;
3901 /* decrease refcount of the stash that owns this GV, if any */
3903 SvREFCNT_dec(stash);
3904 return; /* not break, SvFLAGS reset already happened */
3906 del_XPVBM(SvANY(sv));
3909 del_XPVFM(SvANY(sv));
3912 del_XPVIO(SvANY(sv));
3915 SvFLAGS(sv) &= SVf_BREAK;
3916 SvFLAGS(sv) |= SVTYPEMASK;
3920 Perl_sv_newref(pTHX_ SV *sv)
3923 ATOMIC_INC(SvREFCNT(sv));
3930 Free the memory used by an SV.
3936 Perl_sv_free(pTHX_ SV *sv)
3939 int refcount_is_zero;
3943 if (SvREFCNT(sv) == 0) {
3944 if (SvFLAGS(sv) & SVf_BREAK)
3946 if (PL_in_clean_all) /* All is fair */
3948 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3949 /* make sure SvREFCNT(sv)==0 happens very seldom */
3950 SvREFCNT(sv) = (~(U32)0)/2;
3953 if (ckWARN_d(WARN_INTERNAL))
3954 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3957 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3958 if (!refcount_is_zero)
3962 if (ckWARN_d(WARN_DEBUGGING))
3963 Perl_warner(aTHX_ WARN_DEBUGGING,
3964 "Attempt to free temp prematurely: SV 0x%"UVxf,
3969 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3970 /* make sure SvREFCNT(sv)==0 happens very seldom */
3971 SvREFCNT(sv) = (~(U32)0)/2;
3982 Returns the length of the string in the SV. See also C<SvCUR>.
3988 Perl_sv_len(pTHX_ register SV *sv)
3997 len = mg_length(sv);
3999 junk = SvPV(sv, len);
4004 =for apidoc sv_len_utf8
4006 Returns the number of characters in the string in an SV, counting wide
4007 UTF8 bytes as a single character.
4013 Perl_sv_len_utf8(pTHX_ register SV *sv)
4024 len = mg_length(sv);
4027 s = (U8*)SvPV(sv, len);
4038 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4043 I32 uoffset = *offsetp;
4049 start = s = (U8*)SvPV(sv, len);
4051 while (s < send && uoffset--)
4055 *offsetp = s - start;
4059 while (s < send && ulen--)
4069 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4078 s = (U8*)SvPV(sv, len);
4080 Perl_croak(aTHX_ "panic: bad byte offset");
4081 send = s + *offsetp;
4089 if (ckWARN_d(WARN_UTF8))
4090 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4100 Returns a boolean indicating whether the strings in the two SVs are
4107 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
4119 pv1 = SvPV(str1, cur1);
4124 if (SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
4126 sv_utf8_upgrade(str2);
4129 sv_utf8_upgrade(str1);
4133 pv2 = SvPV(str2, cur2);
4138 return memEQ(pv1, pv2, cur1);
4144 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4145 string in C<sv1> is less than, equal to, or greater than the string in
4152 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
4159 pv1 = SvPV(str1, cur1);
4167 if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
4168 /* must upgrade other to UTF8 first */
4170 sv_utf8_upgrade(str2);
4173 sv_utf8_upgrade(str1);
4174 /* refresh pointer and length */
4183 pv2 = sv_2pv(str2, &cur2);
4191 return cur2 ? -1 : 0;
4196 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4199 return retval < 0 ? -1 : 1;
4204 return cur1 < cur2 ? -1 : 1;
4208 =for apidoc sv_cmp_locale
4210 Compares the strings in two SVs in a locale-aware manner. See
4217 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4219 #ifdef USE_LOCALE_COLLATE
4225 if (PL_collation_standard)
4229 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4231 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4233 if (!pv1 || !len1) {
4244 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4247 return retval < 0 ? -1 : 1;
4250 * When the result of collation is equality, that doesn't mean
4251 * that there are no differences -- some locales exclude some
4252 * characters from consideration. So to avoid false equalities,
4253 * we use the raw string as a tiebreaker.
4259 #endif /* USE_LOCALE_COLLATE */
4261 return sv_cmp(sv1, sv2);
4264 #ifdef USE_LOCALE_COLLATE
4266 * Any scalar variable may carry an 'o' magic that contains the
4267 * scalar data of the variable transformed to such a format that
4268 * a normal memory comparison can be used to compare the data
4269 * according to the locale settings.
4272 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4276 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4277 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4282 Safefree(mg->mg_ptr);
4284 if ((xf = mem_collxfrm(s, len, &xlen))) {
4285 if (SvREADONLY(sv)) {
4288 return xf + sizeof(PL_collation_ix);
4291 sv_magic(sv, 0, 'o', 0, 0);
4292 mg = mg_find(sv, 'o');
4305 if (mg && mg->mg_ptr) {
4307 return mg->mg_ptr + sizeof(PL_collation_ix);
4315 #endif /* USE_LOCALE_COLLATE */
4320 Get a line from the filehandle and store it into the SV, optionally
4321 appending to the currently-stored string.
4327 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4332 register STDCHAR rslast;
4333 register STDCHAR *bp;
4337 SV_CHECK_THINKFIRST(sv);
4338 (void)SvUPGRADE(sv, SVt_PV);
4342 if (RsSNARF(PL_rs)) {
4346 else if (RsRECORD(PL_rs)) {
4347 I32 recsize, bytesread;
4350 /* Grab the size of the record we're getting */
4351 recsize = SvIV(SvRV(PL_rs));
4352 (void)SvPOK_only(sv); /* Validate pointer */
4353 buffer = SvGROW(sv, recsize + 1);
4356 /* VMS wants read instead of fread, because fread doesn't respect */
4357 /* RMS record boundaries. This is not necessarily a good thing to be */
4358 /* doing, but we've got no other real choice */
4359 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4361 bytesread = PerlIO_read(fp, buffer, recsize);
4363 SvCUR_set(sv, bytesread);
4364 buffer[bytesread] = '\0';
4365 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4367 else if (RsPARA(PL_rs)) {
4372 rsptr = SvPV(PL_rs, rslen);
4373 rslast = rslen ? rsptr[rslen - 1] : '\0';
4375 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4376 do { /* to make sure file boundaries work right */
4379 i = PerlIO_getc(fp);
4383 PerlIO_ungetc(fp,i);
4389 /* See if we know enough about I/O mechanism to cheat it ! */
4391 /* This used to be #ifdef test - it is made run-time test for ease
4392 of abstracting out stdio interface. One call should be cheap
4393 enough here - and may even be a macro allowing compile
4397 if (PerlIO_fast_gets(fp)) {
4400 * We're going to steal some values from the stdio struct
4401 * and put EVERYTHING in the innermost loop into registers.
4403 register STDCHAR *ptr;
4407 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4408 /* An ungetc()d char is handled separately from the regular
4409 * buffer, so we getc() it back out and stuff it in the buffer.
4411 i = PerlIO_getc(fp);
4412 if (i == EOF) return 0;
4413 *(--((*fp)->_ptr)) = (unsigned char) i;
4417 /* Here is some breathtakingly efficient cheating */
4419 cnt = PerlIO_get_cnt(fp); /* get count into register */
4420 (void)SvPOK_only(sv); /* validate pointer */
4421 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4422 if (cnt > 80 && SvLEN(sv) > append) {
4423 shortbuffered = cnt - SvLEN(sv) + append + 1;
4424 cnt -= shortbuffered;
4428 /* remember that cnt can be negative */
4429 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4434 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4435 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4436 DEBUG_P(PerlIO_printf(Perl_debug_log,
4437 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4438 DEBUG_P(PerlIO_printf(Perl_debug_log,
4439 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4440 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4441 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4446 while (cnt > 0) { /* this | eat */
4448 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4449 goto thats_all_folks; /* screams | sed :-) */
4453 Copy(ptr, bp, cnt, char); /* this | eat */
4454 bp += cnt; /* screams | dust */
4455 ptr += cnt; /* louder | sed :-) */
4460 if (shortbuffered) { /* oh well, must extend */
4461 cnt = shortbuffered;
4463 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4465 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4466 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4470 DEBUG_P(PerlIO_printf(Perl_debug_log,
4471 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4472 PTR2UV(ptr),(long)cnt));
4473 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4474 DEBUG_P(PerlIO_printf(Perl_debug_log,
4475 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4476 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4477 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4478 /* This used to call 'filbuf' in stdio form, but as that behaves like
4479 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4480 another abstraction. */
4481 i = PerlIO_getc(fp); /* get more characters */
4482 DEBUG_P(PerlIO_printf(Perl_debug_log,
4483 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4484 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4485 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4486 cnt = PerlIO_get_cnt(fp);
4487 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4488 DEBUG_P(PerlIO_printf(Perl_debug_log,
4489 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4491 if (i == EOF) /* all done for ever? */
4492 goto thats_really_all_folks;
4494 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4496 SvGROW(sv, bpx + cnt + 2);
4497 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4499 *bp++ = i; /* store character from PerlIO_getc */
4501 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4502 goto thats_all_folks;
4506 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4507 memNE((char*)bp - rslen, rsptr, rslen))
4508 goto screamer; /* go back to the fray */
4509 thats_really_all_folks:
4511 cnt += shortbuffered;
4512 DEBUG_P(PerlIO_printf(Perl_debug_log,
4513 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4514 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4515 DEBUG_P(PerlIO_printf(Perl_debug_log,
4516 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4517 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4518 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4520 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4521 DEBUG_P(PerlIO_printf(Perl_debug_log,
4522 "Screamer: done, len=%ld, string=|%.*s|\n",
4523 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4528 /*The big, slow, and stupid way */
4531 /* Need to work around EPOC SDK features */
4532 /* On WINS: MS VC5 generates calls to _chkstk, */
4533 /* if a `large' stack frame is allocated */
4534 /* gcc on MARM does not generate calls like these */
4540 register STDCHAR *bpe = buf + sizeof(buf);
4542 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4543 ; /* keep reading */
4547 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4548 /* Accomodate broken VAXC compiler, which applies U8 cast to
4549 * both args of ?: operator, causing EOF to change into 255
4551 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4555 sv_catpvn(sv, (char *) buf, cnt);
4557 sv_setpvn(sv, (char *) buf, cnt);
4559 if (i != EOF && /* joy */
4561 SvCUR(sv) < rslen ||
4562 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4566 * If we're reading from a TTY and we get a short read,
4567 * indicating that the user hit his EOF character, we need
4568 * to notice it now, because if we try to read from the TTY
4569 * again, the EOF condition will disappear.
4571 * The comparison of cnt to sizeof(buf) is an optimization
4572 * that prevents unnecessary calls to feof().
4576 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4581 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4582 while (i != EOF) { /* to make sure file boundaries work right */
4583 i = PerlIO_getc(fp);
4585 PerlIO_ungetc(fp,i);
4591 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4598 Auto-increment of the value in the SV.
4604 Perl_sv_inc(pTHX_ register SV *sv)
4613 if (SvTHINKFIRST(sv)) {
4614 if (SvREADONLY(sv)) {
4616 if (PL_curcop != &PL_compiling)
4617 Perl_croak(aTHX_ PL_no_modify);
4621 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4623 i = PTR2IV(SvRV(sv));
4628 flags = SvFLAGS(sv);
4629 if (flags & SVp_NOK) {
4630 (void)SvNOK_only(sv);
4634 if (flags & SVp_IOK) {
4636 if (SvUVX(sv) == UV_MAX)
4637 sv_setnv(sv, (NV)UV_MAX + 1.0);
4639 (void)SvIOK_only_UV(sv);
4642 if (SvIVX(sv) == IV_MAX)
4643 sv_setnv(sv, (NV)IV_MAX + 1.0);
4645 (void)SvIOK_only(sv);
4651 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4652 if ((flags & SVTYPEMASK) < SVt_PVNV)
4653 sv_upgrade(sv, SVt_NV);
4655 (void)SvNOK_only(sv);
4659 while (isALPHA(*d)) d++;
4660 while (isDIGIT(*d)) d++;
4662 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4666 while (d >= SvPVX(sv)) {
4674 /* MKS: The original code here died if letters weren't consecutive.
4675 * at least it didn't have to worry about non-C locales. The
4676 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4677 * arranged in order (although not consecutively) and that only
4678 * [A-Za-z] are accepted by isALPHA in the C locale.
4680 if (*d != 'z' && *d != 'Z') {
4681 do { ++*d; } while (!isALPHA(*d));
4684 *(d--) -= 'z' - 'a';
4689 *(d--) -= 'z' - 'a' + 1;
4693 /* oh,oh, the number grew */
4694 SvGROW(sv, SvCUR(sv) + 2);
4696 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4707 Auto-decrement of the value in the SV.
4713 Perl_sv_dec(pTHX_ register SV *sv)
4721 if (SvTHINKFIRST(sv)) {
4722 if (SvREADONLY(sv)) {
4724 if (PL_curcop != &PL_compiling)
4725 Perl_croak(aTHX_ PL_no_modify);
4729 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4731 i = PTR2IV(SvRV(sv));
4736 flags = SvFLAGS(sv);
4737 if (flags & SVp_NOK) {
4739 (void)SvNOK_only(sv);
4742 if (flags & SVp_IOK) {
4744 if (SvUVX(sv) == 0) {
4745 (void)SvIOK_only(sv);
4749 (void)SvIOK_only_UV(sv);
4753 if (SvIVX(sv) == IV_MIN)
4754 sv_setnv(sv, (NV)IV_MIN - 1.0);
4756 (void)SvIOK_only(sv);
4762 if (!(flags & SVp_POK)) {
4763 if ((flags & SVTYPEMASK) < SVt_PVNV)
4764 sv_upgrade(sv, SVt_NV);
4766 (void)SvNOK_only(sv);
4769 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4773 =for apidoc sv_mortalcopy
4775 Creates a new SV which is a copy of the original SV. The new SV is marked
4781 /* Make a string that will exist for the duration of the expression
4782 * evaluation. Actually, it may have to last longer than that, but
4783 * hopefully we won't free it until it has been assigned to a
4784 * permanent location. */
4787 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4793 sv_setsv(sv,oldstr);
4795 PL_tmps_stack[++PL_tmps_ix] = sv;
4801 =for apidoc sv_newmortal
4803 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4809 Perl_sv_newmortal(pTHX)
4815 SvFLAGS(sv) = SVs_TEMP;
4817 PL_tmps_stack[++PL_tmps_ix] = sv;
4822 =for apidoc sv_2mortal
4824 Marks an SV as mortal. The SV will be destroyed when the current context
4830 /* same thing without the copying */
4833 Perl_sv_2mortal(pTHX_ register SV *sv)
4838 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4841 PL_tmps_stack[++PL_tmps_ix] = sv;
4849 Creates a new SV and copies a string into it. The reference count for the
4850 SV is set to 1. If C<len> is zero, Perl will compute the length using
4851 strlen(). For efficiency, consider using C<newSVpvn> instead.
4857 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4864 sv_setpvn(sv,s,len);
4869 =for apidoc newSVpvn
4871 Creates a new SV and copies a string into it. The reference count for the
4872 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4873 string. You are responsible for ensuring that the source string is at least
4880 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4885 sv_setpvn(sv,s,len);
4889 #if defined(PERL_IMPLICIT_CONTEXT)
4891 Perl_newSVpvf_nocontext(const char* pat, ...)
4896 va_start(args, pat);
4897 sv = vnewSVpvf(pat, &args);
4904 =for apidoc newSVpvf
4906 Creates a new SV an initialize it with the string formatted like
4913 Perl_newSVpvf(pTHX_ const char* pat, ...)
4917 va_start(args, pat);
4918 sv = vnewSVpvf(pat, &args);
4924 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4928 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4935 Creates a new SV and copies a floating point value into it.
4936 The reference count for the SV is set to 1.
4942 Perl_newSVnv(pTHX_ NV n)
4954 Creates a new SV and copies an integer into it. The reference count for the
4961 Perl_newSViv(pTHX_ IV i)
4973 Creates a new SV and copies an unsigned integer into it.
4974 The reference count for the SV is set to 1.
4980 Perl_newSVuv(pTHX_ UV u)
4990 =for apidoc newRV_noinc
4992 Creates an RV wrapper for an SV. The reference count for the original
4993 SV is B<not> incremented.
4999 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5005 sv_upgrade(sv, SVt_RV);
5012 /* newRV_inc is #defined to newRV in sv.h */
5014 Perl_newRV(pTHX_ SV *tmpRef)
5016 return newRV_noinc(SvREFCNT_inc(tmpRef));
5022 Creates a new SV which is an exact duplicate of the original SV.
5027 /* make an exact duplicate of old */
5030 Perl_newSVsv(pTHX_ register SV *old)
5037 if (SvTYPE(old) == SVTYPEMASK) {
5038 if (ckWARN_d(WARN_INTERNAL))
5039 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5054 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5062 char todo[PERL_UCHAR_MAX+1];
5067 if (!*s) { /* reset ?? searches */
5068 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5069 pm->op_pmdynflags &= ~PMdf_USED;
5074 /* reset variables */
5076 if (!HvARRAY(stash))
5079 Zero(todo, 256, char);
5081 i = (unsigned char)*s;
5085 max = (unsigned char)*s++;
5086 for ( ; i <= max; i++) {
5089 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5090 for (entry = HvARRAY(stash)[i];
5092 entry = HeNEXT(entry))
5094 if (!todo[(U8)*HeKEY(entry)])
5096 gv = (GV*)HeVAL(entry);
5098 if (SvTHINKFIRST(sv)) {
5099 if (!SvREADONLY(sv) && SvROK(sv))
5104 if (SvTYPE(sv) >= SVt_PV) {
5106 if (SvPVX(sv) != Nullch)
5113 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5115 #ifndef VMS /* VMS has no environ array */
5117 environ[0] = Nullch;
5126 Perl_sv_2io(pTHX_ SV *sv)
5132 switch (SvTYPE(sv)) {
5140 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5144 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5146 return sv_2io(SvRV(sv));
5147 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5153 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5160 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5167 return *gvp = Nullgv, Nullcv;
5168 switch (SvTYPE(sv)) {
5188 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5189 tryAMAGICunDEREF(to_cv);
5192 if (SvTYPE(sv) == SVt_PVCV) {
5201 Perl_croak(aTHX_ "Not a subroutine reference");
5206 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5212 if (lref && !GvCVu(gv)) {
5215 tmpsv = NEWSV(704,0);
5216 gv_efullname3(tmpsv, gv, Nullch);
5217 /* XXX this is probably not what they think they're getting.
5218 * It has the same effect as "sub name;", i.e. just a forward
5220 newSUB(start_subparse(FALSE, 0),
5221 newSVOP(OP_CONST, 0, tmpsv),
5226 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5235 Returns true if the SV has a true value by Perl's rules.
5241 Perl_sv_true(pTHX_ register SV *sv)
5248 if ((tXpv = (XPV*)SvANY(sv)) &&
5249 (tXpv->xpv_cur > 1 ||
5250 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5257 return SvIVX(sv) != 0;
5260 return SvNVX(sv) != 0.0;
5262 return sv_2bool(sv);
5268 Perl_sv_iv(pTHX_ register SV *sv)
5272 return (IV)SvUVX(sv);
5279 Perl_sv_uv(pTHX_ register SV *sv)
5284 return (UV)SvIVX(sv);
5290 Perl_sv_nv(pTHX_ register SV *sv)
5298 Perl_sv_pv(pTHX_ SV *sv)
5305 return sv_2pv(sv, &n_a);
5309 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5315 return sv_2pv(sv, lp);
5319 =for apidoc sv_pvn_force
5321 Get a sensible string out of the SV somehow.
5327 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5331 if (SvTHINKFIRST(sv) && !SvROK(sv))
5332 sv_force_normal(sv);
5338 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5340 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5341 PL_op_name[PL_op->op_type]);
5345 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5350 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5351 SvGROW(sv, len + 1);
5352 Move(s,SvPVX(sv),len,char);
5357 SvPOK_on(sv); /* validate pointer */
5359 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5360 PTR2UV(sv),SvPVX(sv)));
5367 Perl_sv_pvbyte(pTHX_ SV *sv)
5373 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5375 return sv_pvn(sv,lp);
5379 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5381 return sv_pvn_force(sv,lp);
5385 Perl_sv_pvutf8(pTHX_ SV *sv)
5387 sv_utf8_upgrade(sv);
5392 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5394 sv_utf8_upgrade(sv);
5395 return sv_pvn(sv,lp);
5399 =for apidoc sv_pvutf8n_force
5401 Get a sensible UTF8-encoded string out of the SV somehow. See
5408 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5410 sv_utf8_upgrade(sv);
5411 return sv_pvn_force(sv,lp);
5415 =for apidoc sv_reftype
5417 Returns a string describing what the SV is a reference to.
5423 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5425 if (ob && SvOBJECT(sv))
5426 return HvNAME(SvSTASH(sv));
5428 switch (SvTYPE(sv)) {
5442 case SVt_PVLV: return "LVALUE";
5443 case SVt_PVAV: return "ARRAY";
5444 case SVt_PVHV: return "HASH";
5445 case SVt_PVCV: return "CODE";
5446 case SVt_PVGV: return "GLOB";
5447 case SVt_PVFM: return "FORMAT";
5448 case SVt_PVIO: return "IO";
5449 default: return "UNKNOWN";
5455 =for apidoc sv_isobject
5457 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5458 object. If the SV is not an RV, or if the object is not blessed, then this
5465 Perl_sv_isobject(pTHX_ SV *sv)
5482 Returns a boolean indicating whether the SV is blessed into the specified
5483 class. This does not check for subtypes; use C<sv_derived_from> to verify
5484 an inheritance relationship.
5490 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5502 return strEQ(HvNAME(SvSTASH(sv)), name);
5508 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5509 it will be upgraded to one. If C<classname> is non-null then the new SV will
5510 be blessed in the specified package. The new SV is returned and its
5511 reference count is 1.
5517 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5524 SV_CHECK_THINKFIRST(rv);
5527 if (SvTYPE(rv) < SVt_RV)
5528 sv_upgrade(rv, SVt_RV);
5535 HV* stash = gv_stashpv(classname, TRUE);
5536 (void)sv_bless(rv, stash);
5542 =for apidoc sv_setref_pv
5544 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5545 argument will be upgraded to an RV. That RV will be modified to point to
5546 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5547 into the SV. The C<classname> argument indicates the package for the
5548 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5549 will be returned and will have a reference count of 1.
5551 Do not use with other Perl types such as HV, AV, SV, CV, because those
5552 objects will become corrupted by the pointer copy process.
5554 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5560 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5563 sv_setsv(rv, &PL_sv_undef);
5567 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5572 =for apidoc sv_setref_iv
5574 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5575 argument will be upgraded to an RV. That RV will be modified to point to
5576 the new SV. The C<classname> argument indicates the package for the
5577 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5578 will be returned and will have a reference count of 1.
5584 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5586 sv_setiv(newSVrv(rv,classname), iv);
5591 =for apidoc sv_setref_nv
5593 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5594 argument will be upgraded to an RV. That RV will be modified to point to
5595 the new SV. The C<classname> argument indicates the package for the
5596 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5597 will be returned and will have a reference count of 1.
5603 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5605 sv_setnv(newSVrv(rv,classname), nv);
5610 =for apidoc sv_setref_pvn
5612 Copies a string into a new SV, optionally blessing the SV. The length of the
5613 string must be specified with C<n>. The C<rv> argument will be upgraded to
5614 an RV. That RV will be modified to point to the new SV. The C<classname>
5615 argument indicates the package for the blessing. Set C<classname> to
5616 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5617 a reference count of 1.
5619 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5625 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5627 sv_setpvn(newSVrv(rv,classname), pv, n);
5632 =for apidoc sv_bless
5634 Blesses an SV into a specified package. The SV must be an RV. The package
5635 must be designated by its stash (see C<gv_stashpv()>). The reference count
5636 of the SV is unaffected.
5642 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5647 Perl_croak(aTHX_ "Can't bless non-reference value");
5649 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5650 if (SvREADONLY(tmpRef))
5651 Perl_croak(aTHX_ PL_no_modify);
5652 if (SvOBJECT(tmpRef)) {
5653 if (SvTYPE(tmpRef) != SVt_PVIO)
5655 SvREFCNT_dec(SvSTASH(tmpRef));
5658 SvOBJECT_on(tmpRef);
5659 if (SvTYPE(tmpRef) != SVt_PVIO)
5661 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5662 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5673 S_sv_unglob(pTHX_ SV *sv)
5677 assert(SvTYPE(sv) == SVt_PVGV);
5682 SvREFCNT_dec(GvSTASH(sv));
5683 GvSTASH(sv) = Nullhv;
5685 sv_unmagic(sv, '*');
5686 Safefree(GvNAME(sv));
5689 /* need to keep SvANY(sv) in the right arena */
5690 xpvmg = new_XPVMG();
5691 StructCopy(SvANY(sv), xpvmg, XPVMG);
5692 del_XPVGV(SvANY(sv));
5695 SvFLAGS(sv) &= ~SVTYPEMASK;
5696 SvFLAGS(sv) |= SVt_PVMG;
5700 =for apidoc sv_unref
5702 Unsets the RV status of the SV, and decrements the reference count of
5703 whatever was being referenced by the RV. This can almost be thought of
5704 as a reversal of C<newSVrv>. See C<SvROK_off>.
5710 Perl_sv_unref(pTHX_ SV *sv)
5714 if (SvWEAKREF(sv)) {
5722 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5725 sv_2mortal(rv); /* Schedule for freeing later */
5729 Perl_sv_taint(pTHX_ SV *sv)
5731 sv_magic((sv), Nullsv, 't', Nullch, 0);
5735 Perl_sv_untaint(pTHX_ SV *sv)
5737 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5738 MAGIC *mg = mg_find(sv, 't');
5745 Perl_sv_tainted(pTHX_ SV *sv)
5747 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5748 MAGIC *mg = mg_find(sv, 't');
5749 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5756 =for apidoc sv_setpviv
5758 Copies an integer into the given SV, also updating its string value.
5759 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5765 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5767 char buf[TYPE_CHARS(UV)];
5769 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5771 sv_setpvn(sv, ptr, ebuf - ptr);
5776 =for apidoc sv_setpviv_mg
5778 Like C<sv_setpviv>, but also handles 'set' magic.
5784 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5786 char buf[TYPE_CHARS(UV)];
5788 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5790 sv_setpvn(sv, ptr, ebuf - ptr);
5794 #if defined(PERL_IMPLICIT_CONTEXT)
5796 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5800 va_start(args, pat);
5801 sv_vsetpvf(sv, pat, &args);
5807 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5811 va_start(args, pat);
5812 sv_vsetpvf_mg(sv, pat, &args);
5818 =for apidoc sv_setpvf
5820 Processes its arguments like C<sprintf> and sets an SV to the formatted
5821 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5827 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5830 va_start(args, pat);
5831 sv_vsetpvf(sv, pat, &args);
5836 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5838 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5842 =for apidoc sv_setpvf_mg
5844 Like C<sv_setpvf>, but also handles 'set' magic.
5850 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5853 va_start(args, pat);
5854 sv_vsetpvf_mg(sv, pat, &args);
5859 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5861 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5865 #if defined(PERL_IMPLICIT_CONTEXT)
5867 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5871 va_start(args, pat);
5872 sv_vcatpvf(sv, pat, &args);
5877 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5881 va_start(args, pat);
5882 sv_vcatpvf_mg(sv, pat, &args);
5888 =for apidoc sv_catpvf
5890 Processes its arguments like C<sprintf> and appends the formatted output
5891 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5892 typically be called after calling this function to handle 'set' magic.
5898 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5901 va_start(args, pat);
5902 sv_vcatpvf(sv, pat, &args);
5907 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5909 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5913 =for apidoc sv_catpvf_mg
5915 Like C<sv_catpvf>, but also handles 'set' magic.
5921 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5924 va_start(args, pat);
5925 sv_vcatpvf_mg(sv, pat, &args);
5930 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5932 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5937 =for apidoc sv_vsetpvfn
5939 Works like C<vcatpvfn> but copies the text into the SV instead of
5946 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5948 sv_setpvn(sv, "", 0);
5949 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5953 =for apidoc sv_vcatpvfn
5955 Processes its arguments like C<vsprintf> and appends the formatted output
5956 to an SV. Uses an array of SVs if the C style variable argument list is
5957 missing (NULL). When running with taint checks enabled, indicates via
5958 C<maybe_tainted> if results are untrustworthy (often due to the use of
5965 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5973 static char nullstr[] = "(null)";
5976 /* no matter what, this is a string now */
5977 (void)SvPV_force(sv, origlen);
5979 /* special-case "", "%s", and "%_" */
5982 if (patlen == 2 && pat[0] == '%') {
5986 char *s = va_arg(*args, char*);
5987 sv_catpv(sv, s ? s : nullstr);
5989 else if (svix < svmax) {
5990 sv_catsv(sv, *svargs);
5991 if (DO_UTF8(*svargs))
5997 argsv = va_arg(*args, SV*);
5998 sv_catsv(sv, argsv);
6003 /* See comment on '_' below */
6008 patend = (char*)pat + patlen;
6009 for (p = (char*)pat; p < patend; p = q) {
6012 bool vectorize = FALSE;
6019 bool has_precis = FALSE;
6021 bool is_utf = FALSE;
6024 U8 utf8buf[UTF8_MAXLEN];
6025 STRLEN esignlen = 0;
6027 char *eptr = Nullch;
6029 /* Times 4: a decimal digit takes more than 3 binary digits.
6030 * NV_DIG: mantissa takes than many decimal digits.
6031 * Plus 32: Playing safe. */
6032 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6033 /* large enough for "%#.#f" --chip */
6034 /* what about long double NVs? --jhi */
6037 U8 *vecstr = Null(U8*);
6049 STRLEN dotstrlen = 1;
6051 for (q = p; q < patend && *q != '%'; ++q) ;
6053 sv_catpvn(sv, p, q - p);
6082 case '*': /* printf("%*vX",":",$ipv6addr) */
6087 vecsv = va_arg(*args, SV*);
6088 else if (svix < svmax)
6089 vecsv = svargs[svix++];
6092 dotstr = SvPVx(vecsv,dotstrlen);
6111 case '1': case '2': case '3':
6112 case '4': case '5': case '6':
6113 case '7': case '8': case '9':
6116 width = width * 10 + (*q++ - '0');
6121 i = va_arg(*args, int);
6123 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6125 width = (i < 0) ? -i : i;
6136 i = va_arg(*args, int);
6138 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6139 precis = (i < 0) ? 0 : i;
6145 precis = precis * 10 + (*q++ - '0');
6152 vecsv = va_arg(*args, SV*);
6153 vecstr = (U8*)SvPVx(vecsv,veclen);
6154 utf = DO_UTF8(vecsv);
6156 else if (svix < svmax) {
6157 vecsv = svargs[svix++];
6158 vecstr = (U8*)SvPVx(vecsv,veclen);
6159 utf = DO_UTF8(vecsv);
6179 if (*(q + 1) == 'l') { /* lld */
6206 uv = va_arg(*args, int);
6208 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6209 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6210 eptr = (char*)utf8buf;
6211 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6223 eptr = va_arg(*args, char*);
6225 #ifdef MACOS_TRADITIONAL
6226 /* On MacOS, %#s format is used for Pascal strings */
6231 elen = strlen(eptr);
6234 elen = sizeof nullstr - 1;
6237 else if (svix < svmax) {
6238 argsv = svargs[svix++];
6239 eptr = SvPVx(argsv, elen);
6240 if (DO_UTF8(argsv)) {
6241 if (has_precis && precis < elen) {
6243 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6246 if (width) { /* fudge width (can't fudge elen) */
6247 width += elen - sv_len_utf8(argsv);
6256 * The "%_" hack might have to be changed someday,
6257 * if ISO or ANSI decide to use '_' for something.
6258 * So we keep it hidden from users' code.
6262 argsv = va_arg(*args,SV*);
6263 eptr = SvPVx(argsv, elen);
6269 if (has_precis && elen > precis)
6279 uv = PTR2UV(va_arg(*args, void*));
6281 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6301 iv = (IV)utf8_to_uv(vecstr, &ulen);
6311 case 'h': iv = (short)va_arg(*args, int); break;
6312 default: iv = va_arg(*args, int); break;
6313 case 'l': iv = va_arg(*args, long); break;
6314 case 'V': iv = va_arg(*args, IV); break;
6316 case 'q': iv = va_arg(*args, Quad_t); break;
6321 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6323 case 'h': iv = (short)iv; break;
6325 case 'l': iv = (long)iv; break;
6328 case 'q': iv = (Quad_t)iv; break;
6335 esignbuf[esignlen++] = plus;
6339 esignbuf[esignlen++] = '-';
6383 uv = utf8_to_uv(vecstr, &ulen);
6393 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6394 default: uv = va_arg(*args, unsigned); break;
6395 case 'l': uv = va_arg(*args, unsigned long); break;
6396 case 'V': uv = va_arg(*args, UV); break;
6398 case 'q': uv = va_arg(*args, Quad_t); break;
6403 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6405 case 'h': uv = (unsigned short)uv; break;
6407 case 'l': uv = (unsigned long)uv; break;
6410 case 'q': uv = (Quad_t)uv; break;
6416 eptr = ebuf + sizeof ebuf;
6422 p = (char*)((c == 'X')
6423 ? "0123456789ABCDEF" : "0123456789abcdef");
6429 esignbuf[esignlen++] = '0';
6430 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6436 *--eptr = '0' + dig;
6438 if (alt && *eptr != '0')
6444 *--eptr = '0' + dig;
6447 esignbuf[esignlen++] = '0';
6448 esignbuf[esignlen++] = 'b';
6451 default: /* it had better be ten or less */
6452 #if defined(PERL_Y2KWARN)
6453 if (ckWARN(WARN_Y2K)) {
6455 char *s = SvPV(sv,n);
6456 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6457 && (n == 2 || !isDIGIT(s[n-3])))
6459 Perl_warner(aTHX_ WARN_Y2K,
6460 "Possible Y2K bug: %%%c %s",
6461 c, "format string following '19'");
6467 *--eptr = '0' + dig;
6468 } while (uv /= base);
6471 elen = (ebuf + sizeof ebuf) - eptr;
6474 zeros = precis - elen;
6475 else if (precis == 0 && elen == 1 && *eptr == '0')
6480 /* FLOATING POINT */
6483 c = 'f'; /* maybe %F isn't supported here */
6489 /* This is evil, but floating point is even more evil */
6493 nv = va_arg(*args, NV);
6495 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6498 if (c != 'e' && c != 'E') {
6500 (void)Perl_frexp(nv, &i);
6501 if (i == PERL_INT_MIN)
6502 Perl_die(aTHX_ "panic: frexp");
6504 need = BIT_DIGITS(i);
6506 need += has_precis ? precis : 6; /* known default */
6510 need += 20; /* fudge factor */
6511 if (PL_efloatsize < need) {
6512 Safefree(PL_efloatbuf);
6513 PL_efloatsize = need + 20; /* more fudge */
6514 New(906, PL_efloatbuf, PL_efloatsize, char);
6515 PL_efloatbuf[0] = '\0';
6518 eptr = ebuf + sizeof ebuf;
6521 #ifdef USE_LONG_DOUBLE
6523 static char const my_prifldbl[] = PERL_PRIfldbl;
6524 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6525 while (p >= my_prifldbl) { *--eptr = *p--; }
6530 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6535 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6548 RESTORE_NUMERIC_STANDARD();
6549 (void)sprintf(PL_efloatbuf, eptr, nv);
6550 RESTORE_NUMERIC_LOCAL();
6553 eptr = PL_efloatbuf;
6554 elen = strlen(PL_efloatbuf);
6561 i = SvCUR(sv) - origlen;
6564 case 'h': *(va_arg(*args, short*)) = i; break;
6565 default: *(va_arg(*args, int*)) = i; break;
6566 case 'l': *(va_arg(*args, long*)) = i; break;
6567 case 'V': *(va_arg(*args, IV*)) = i; break;
6569 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6573 else if (svix < svmax)
6574 sv_setuv_mg(svargs[svix++], (UV)i);
6575 continue; /* not "break" */
6582 if (!args && ckWARN(WARN_PRINTF) &&
6583 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6584 SV *msg = sv_newmortal();
6585 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6586 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6589 Perl_sv_catpvf(aTHX_ msg,
6590 "\"%%%c\"", c & 0xFF);
6592 Perl_sv_catpvf(aTHX_ msg,
6593 "\"%%\\%03"UVof"\"",
6596 sv_catpv(msg, "end of string");
6597 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6600 /* output mangled stuff ... */
6606 /* ... right here, because formatting flags should not apply */
6607 SvGROW(sv, SvCUR(sv) + elen + 1);
6609 memcpy(p, eptr, elen);
6612 SvCUR(sv) = p - SvPVX(sv);
6613 continue; /* not "break" */
6616 have = esignlen + zeros + elen;
6617 need = (have > width ? have : width);
6620 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6622 if (esignlen && fill == '0') {
6623 for (i = 0; i < esignlen; i++)
6627 memset(p, fill, gap);
6630 if (esignlen && fill != '0') {
6631 for (i = 0; i < esignlen; i++)
6635 for (i = zeros; i; i--)
6639 memcpy(p, eptr, elen);
6643 memset(p, ' ', gap);
6648 memcpy(p, dotstr, dotstrlen);
6652 vectorize = FALSE; /* done iterating over vecstr */
6657 SvCUR(sv) = p - SvPVX(sv);
6665 #if defined(USE_ITHREADS)
6667 #if defined(USE_THREADS)
6668 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6671 #ifndef GpREFCNT_inc
6672 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6676 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6677 #define av_dup(s) (AV*)sv_dup((SV*)s)
6678 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6679 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6680 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6681 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6682 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6683 #define io_dup(s) (IO*)sv_dup((SV*)s)
6684 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6685 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6686 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6687 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6688 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6691 Perl_re_dup(pTHX_ REGEXP *r)
6693 /* XXX fix when pmop->op_pmregexp becomes shared */
6694 return ReREFCNT_inc(r);
6698 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6702 return (PerlIO*)NULL;
6704 /* look for it in the table first */
6705 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6709 /* create anew and remember what it is */
6710 ret = PerlIO_fdupopen(fp);
6711 ptr_table_store(PL_ptr_table, fp, ret);
6716 Perl_dirp_dup(pTHX_ DIR *dp)
6725 Perl_gp_dup(pTHX_ GP *gp)
6730 /* look for it in the table first */
6731 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6735 /* create anew and remember what it is */
6736 Newz(0, ret, 1, GP);
6737 ptr_table_store(PL_ptr_table, gp, ret);
6740 ret->gp_refcnt = 0; /* must be before any other dups! */
6741 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6742 ret->gp_io = io_dup_inc(gp->gp_io);
6743 ret->gp_form = cv_dup_inc(gp->gp_form);
6744 ret->gp_av = av_dup_inc(gp->gp_av);
6745 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6746 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6747 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6748 ret->gp_cvgen = gp->gp_cvgen;
6749 ret->gp_flags = gp->gp_flags;
6750 ret->gp_line = gp->gp_line;
6751 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6756 Perl_mg_dup(pTHX_ MAGIC *mg)
6758 MAGIC *mgret = (MAGIC*)NULL;
6761 return (MAGIC*)NULL;
6762 /* look for it in the table first */
6763 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6767 for (; mg; mg = mg->mg_moremagic) {
6769 Newz(0, nmg, 1, MAGIC);
6773 mgprev->mg_moremagic = nmg;
6774 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6775 nmg->mg_private = mg->mg_private;
6776 nmg->mg_type = mg->mg_type;
6777 nmg->mg_flags = mg->mg_flags;
6778 if (mg->mg_type == 'r') {
6779 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6782 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6783 ? sv_dup_inc(mg->mg_obj)
6784 : sv_dup(mg->mg_obj);
6786 nmg->mg_len = mg->mg_len;
6787 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6788 if (mg->mg_ptr && mg->mg_type != 'g') {
6789 if (mg->mg_len >= 0) {
6790 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6791 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6792 AMT *amtp = (AMT*)mg->mg_ptr;
6793 AMT *namtp = (AMT*)nmg->mg_ptr;
6795 for (i = 1; i < NofAMmeth; i++) {
6796 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6800 else if (mg->mg_len == HEf_SVKEY)
6801 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6809 Perl_ptr_table_new(pTHX)
6812 Newz(0, tbl, 1, PTR_TBL_t);
6815 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6820 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6822 PTR_TBL_ENT_t *tblent;
6823 UV hash = PTR2UV(sv);
6825 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6826 for (; tblent; tblent = tblent->next) {
6827 if (tblent->oldval == sv)
6828 return tblent->newval;
6834 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6836 PTR_TBL_ENT_t *tblent, **otblent;
6837 /* XXX this may be pessimal on platforms where pointers aren't good
6838 * hash values e.g. if they grow faster in the most significant
6840 UV hash = PTR2UV(oldv);
6844 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6845 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6846 if (tblent->oldval == oldv) {
6847 tblent->newval = newv;
6852 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6853 tblent->oldval = oldv;
6854 tblent->newval = newv;
6855 tblent->next = *otblent;
6858 if (i && tbl->tbl_items > tbl->tbl_max)
6859 ptr_table_split(tbl);
6863 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6865 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6866 UV oldsize = tbl->tbl_max + 1;
6867 UV newsize = oldsize * 2;
6870 Renew(ary, newsize, PTR_TBL_ENT_t*);
6871 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6872 tbl->tbl_max = --newsize;
6874 for (i=0; i < oldsize; i++, ary++) {
6875 PTR_TBL_ENT_t **curentp, **entp, *ent;
6878 curentp = ary + oldsize;
6879 for (entp = ary, ent = *ary; ent; ent = *entp) {
6880 if ((newsize & PTR2UV(ent->oldval)) != i) {
6882 ent->next = *curentp;
6897 Perl_sv_dup(pTHX_ SV *sstr)
6901 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6903 /* look for it in the table first */
6904 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6908 /* create anew and remember what it is */
6910 ptr_table_store(PL_ptr_table, sstr, dstr);
6913 SvFLAGS(dstr) = SvFLAGS(sstr);
6914 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6915 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6918 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6919 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6920 PL_watch_pvx, SvPVX(sstr));
6923 switch (SvTYPE(sstr)) {
6928 SvANY(dstr) = new_XIV();
6929 SvIVX(dstr) = SvIVX(sstr);
6932 SvANY(dstr) = new_XNV();
6933 SvNVX(dstr) = SvNVX(sstr);
6936 SvANY(dstr) = new_XRV();
6937 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6940 SvANY(dstr) = new_XPV();
6941 SvCUR(dstr) = SvCUR(sstr);
6942 SvLEN(dstr) = SvLEN(sstr);
6944 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6945 else if (SvPVX(sstr) && SvLEN(sstr))
6946 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6948 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6951 SvANY(dstr) = new_XPVIV();
6952 SvCUR(dstr) = SvCUR(sstr);
6953 SvLEN(dstr) = SvLEN(sstr);
6954 SvIVX(dstr) = SvIVX(sstr);
6956 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6957 else if (SvPVX(sstr) && SvLEN(sstr))
6958 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6960 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6963 SvANY(dstr) = new_XPVNV();
6964 SvCUR(dstr) = SvCUR(sstr);
6965 SvLEN(dstr) = SvLEN(sstr);
6966 SvIVX(dstr) = SvIVX(sstr);
6967 SvNVX(dstr) = SvNVX(sstr);
6969 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6970 else if (SvPVX(sstr) && SvLEN(sstr))
6971 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6973 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6976 SvANY(dstr) = new_XPVMG();
6977 SvCUR(dstr) = SvCUR(sstr);
6978 SvLEN(dstr) = SvLEN(sstr);
6979 SvIVX(dstr) = SvIVX(sstr);
6980 SvNVX(dstr) = SvNVX(sstr);
6981 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6982 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6984 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6985 else if (SvPVX(sstr) && SvLEN(sstr))
6986 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6988 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6991 SvANY(dstr) = new_XPVBM();
6992 SvCUR(dstr) = SvCUR(sstr);
6993 SvLEN(dstr) = SvLEN(sstr);
6994 SvIVX(dstr) = SvIVX(sstr);
6995 SvNVX(dstr) = SvNVX(sstr);
6996 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6997 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6999 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7000 else if (SvPVX(sstr) && SvLEN(sstr))
7001 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7003 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7004 BmRARE(dstr) = BmRARE(sstr);
7005 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7006 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7009 SvANY(dstr) = new_XPVLV();
7010 SvCUR(dstr) = SvCUR(sstr);
7011 SvLEN(dstr) = SvLEN(sstr);
7012 SvIVX(dstr) = SvIVX(sstr);
7013 SvNVX(dstr) = SvNVX(sstr);
7014 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7015 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7017 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7018 else if (SvPVX(sstr) && SvLEN(sstr))
7019 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7021 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7022 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7023 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7024 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7025 LvTYPE(dstr) = LvTYPE(sstr);
7028 SvANY(dstr) = new_XPVGV();
7029 SvCUR(dstr) = SvCUR(sstr);
7030 SvLEN(dstr) = SvLEN(sstr);
7031 SvIVX(dstr) = SvIVX(sstr);
7032 SvNVX(dstr) = SvNVX(sstr);
7033 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7034 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7036 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7037 else if (SvPVX(sstr) && SvLEN(sstr))
7038 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7040 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7041 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7042 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7043 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7044 GvFLAGS(dstr) = GvFLAGS(sstr);
7045 GvGP(dstr) = gp_dup(GvGP(sstr));
7046 (void)GpREFCNT_inc(GvGP(dstr));
7049 SvANY(dstr) = new_XPVIO();
7050 SvCUR(dstr) = SvCUR(sstr);
7051 SvLEN(dstr) = SvLEN(sstr);
7052 SvIVX(dstr) = SvIVX(sstr);
7053 SvNVX(dstr) = SvNVX(sstr);
7054 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7055 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7057 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7058 else if (SvPVX(sstr) && SvLEN(sstr))
7059 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7061 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7062 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7063 if (IoOFP(sstr) == IoIFP(sstr))
7064 IoOFP(dstr) = IoIFP(dstr);
7066 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7067 /* PL_rsfp_filters entries have fake IoDIRP() */
7068 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7069 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7071 IoDIRP(dstr) = IoDIRP(sstr);
7072 IoLINES(dstr) = IoLINES(sstr);
7073 IoPAGE(dstr) = IoPAGE(sstr);
7074 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7075 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7076 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7077 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7078 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7079 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7080 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7081 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7082 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7083 IoTYPE(dstr) = IoTYPE(sstr);
7084 IoFLAGS(dstr) = IoFLAGS(sstr);
7087 SvANY(dstr) = new_XPVAV();
7088 SvCUR(dstr) = SvCUR(sstr);
7089 SvLEN(dstr) = SvLEN(sstr);
7090 SvIVX(dstr) = SvIVX(sstr);
7091 SvNVX(dstr) = SvNVX(sstr);
7092 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7093 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7094 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7095 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7096 if (AvARRAY((AV*)sstr)) {
7097 SV **dst_ary, **src_ary;
7098 SSize_t items = AvFILLp((AV*)sstr) + 1;
7100 src_ary = AvARRAY((AV*)sstr);
7101 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7102 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7103 SvPVX(dstr) = (char*)dst_ary;
7104 AvALLOC((AV*)dstr) = dst_ary;
7105 if (AvREAL((AV*)sstr)) {
7107 *dst_ary++ = sv_dup_inc(*src_ary++);
7111 *dst_ary++ = sv_dup(*src_ary++);
7113 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7114 while (items-- > 0) {
7115 *dst_ary++ = &PL_sv_undef;
7119 SvPVX(dstr) = Nullch;
7120 AvALLOC((AV*)dstr) = (SV**)NULL;
7124 SvANY(dstr) = new_XPVHV();
7125 SvCUR(dstr) = SvCUR(sstr);
7126 SvLEN(dstr) = SvLEN(sstr);
7127 SvIVX(dstr) = SvIVX(sstr);
7128 SvNVX(dstr) = SvNVX(sstr);
7129 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7130 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7131 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7132 if (HvARRAY((HV*)sstr)) {
7134 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7135 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7136 Newz(0, dxhv->xhv_array,
7137 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7138 while (i <= sxhv->xhv_max) {
7139 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7140 !!HvSHAREKEYS(sstr));
7143 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7146 SvPVX(dstr) = Nullch;
7147 HvEITER((HV*)dstr) = (HE*)NULL;
7149 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7150 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7153 SvANY(dstr) = new_XPVFM();
7154 FmLINES(dstr) = FmLINES(sstr);
7158 SvANY(dstr) = new_XPVCV();
7160 SvCUR(dstr) = SvCUR(sstr);
7161 SvLEN(dstr) = SvLEN(sstr);
7162 SvIVX(dstr) = SvIVX(sstr);
7163 SvNVX(dstr) = SvNVX(sstr);
7164 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7165 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7166 if (SvPVX(sstr) && SvLEN(sstr))
7167 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7169 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7170 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7171 CvSTART(dstr) = CvSTART(sstr);
7172 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7173 CvXSUB(dstr) = CvXSUB(sstr);
7174 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7175 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7176 CvDEPTH(dstr) = CvDEPTH(sstr);
7177 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7178 /* XXX padlists are real, but pretend to be not */
7179 AvREAL_on(CvPADLIST(sstr));
7180 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7181 AvREAL_off(CvPADLIST(sstr));
7182 AvREAL_off(CvPADLIST(dstr));
7185 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7186 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7187 CvFLAGS(dstr) = CvFLAGS(sstr);
7190 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7194 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7201 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7206 return (PERL_CONTEXT*)NULL;
7208 /* look for it in the table first */
7209 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7213 /* create anew and remember what it is */
7214 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7215 ptr_table_store(PL_ptr_table, cxs, ncxs);
7218 PERL_CONTEXT *cx = &cxs[ix];
7219 PERL_CONTEXT *ncx = &ncxs[ix];
7220 ncx->cx_type = cx->cx_type;
7221 if (CxTYPE(cx) == CXt_SUBST) {
7222 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7225 ncx->blk_oldsp = cx->blk_oldsp;
7226 ncx->blk_oldcop = cx->blk_oldcop;
7227 ncx->blk_oldretsp = cx->blk_oldretsp;
7228 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7229 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7230 ncx->blk_oldpm = cx->blk_oldpm;
7231 ncx->blk_gimme = cx->blk_gimme;
7232 switch (CxTYPE(cx)) {
7234 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7235 ? cv_dup_inc(cx->blk_sub.cv)
7236 : cv_dup(cx->blk_sub.cv));
7237 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7238 ? av_dup_inc(cx->blk_sub.argarray)
7240 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7241 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7242 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7243 ncx->blk_sub.lval = cx->blk_sub.lval;
7246 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7247 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7248 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7249 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7250 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7253 ncx->blk_loop.label = cx->blk_loop.label;
7254 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7255 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7256 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7257 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7258 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7259 ? cx->blk_loop.iterdata
7260 : gv_dup((GV*)cx->blk_loop.iterdata));
7261 ncx->blk_loop.oldcurpad
7262 = (SV**)ptr_table_fetch(PL_ptr_table,
7263 cx->blk_loop.oldcurpad);
7264 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7265 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7266 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7267 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7268 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7271 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7272 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7273 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7274 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7287 Perl_si_dup(pTHX_ PERL_SI *si)
7292 return (PERL_SI*)NULL;
7294 /* look for it in the table first */
7295 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7299 /* create anew and remember what it is */
7300 Newz(56, nsi, 1, PERL_SI);
7301 ptr_table_store(PL_ptr_table, si, nsi);
7303 nsi->si_stack = av_dup_inc(si->si_stack);
7304 nsi->si_cxix = si->si_cxix;
7305 nsi->si_cxmax = si->si_cxmax;
7306 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7307 nsi->si_type = si->si_type;
7308 nsi->si_prev = si_dup(si->si_prev);
7309 nsi->si_next = si_dup(si->si_next);
7310 nsi->si_markoff = si->si_markoff;
7315 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7316 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7317 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7318 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7319 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7320 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7321 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7322 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7323 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7324 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7325 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7326 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7329 #define pv_dup_inc(p) SAVEPV(p)
7330 #define pv_dup(p) SAVEPV(p)
7331 #define svp_dup_inc(p,pp) any_dup(p,pp)
7334 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7341 /* look for it in the table first */
7342 ret = ptr_table_fetch(PL_ptr_table, v);
7346 /* see if it is part of the interpreter structure */
7347 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7348 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7356 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7358 ANY *ss = proto_perl->Tsavestack;
7359 I32 ix = proto_perl->Tsavestack_ix;
7360 I32 max = proto_perl->Tsavestack_max;
7373 void (*dptr) (void*);
7374 void (*dxptr) (pTHXo_ void*);
7377 Newz(54, nss, max, ANY);
7383 case SAVEt_ITEM: /* normal string */
7384 sv = (SV*)POPPTR(ss,ix);
7385 TOPPTR(nss,ix) = sv_dup_inc(sv);
7386 sv = (SV*)POPPTR(ss,ix);
7387 TOPPTR(nss,ix) = sv_dup_inc(sv);
7389 case SAVEt_SV: /* scalar reference */
7390 sv = (SV*)POPPTR(ss,ix);
7391 TOPPTR(nss,ix) = sv_dup_inc(sv);
7392 gv = (GV*)POPPTR(ss,ix);
7393 TOPPTR(nss,ix) = gv_dup_inc(gv);
7395 case SAVEt_GENERIC_PVREF: /* generic char* */
7396 c = (char*)POPPTR(ss,ix);
7397 TOPPTR(nss,ix) = pv_dup(c);
7398 ptr = POPPTR(ss,ix);
7399 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7401 case SAVEt_GENERIC_SVREF: /* generic sv */
7402 case SAVEt_SVREF: /* scalar reference */
7403 sv = (SV*)POPPTR(ss,ix);
7404 TOPPTR(nss,ix) = sv_dup_inc(sv);
7405 ptr = POPPTR(ss,ix);
7406 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7408 case SAVEt_AV: /* array reference */
7409 av = (AV*)POPPTR(ss,ix);
7410 TOPPTR(nss,ix) = av_dup_inc(av);
7411 gv = (GV*)POPPTR(ss,ix);
7412 TOPPTR(nss,ix) = gv_dup(gv);
7414 case SAVEt_HV: /* hash reference */
7415 hv = (HV*)POPPTR(ss,ix);
7416 TOPPTR(nss,ix) = hv_dup_inc(hv);
7417 gv = (GV*)POPPTR(ss,ix);
7418 TOPPTR(nss,ix) = gv_dup(gv);
7420 case SAVEt_INT: /* int reference */
7421 ptr = POPPTR(ss,ix);
7422 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7423 intval = (int)POPINT(ss,ix);
7424 TOPINT(nss,ix) = intval;
7426 case SAVEt_LONG: /* long reference */
7427 ptr = POPPTR(ss,ix);
7428 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7429 longval = (long)POPLONG(ss,ix);
7430 TOPLONG(nss,ix) = longval;
7432 case SAVEt_I32: /* I32 reference */
7433 case SAVEt_I16: /* I16 reference */
7434 case SAVEt_I8: /* I8 reference */
7435 ptr = POPPTR(ss,ix);
7436 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7440 case SAVEt_IV: /* IV reference */
7441 ptr = POPPTR(ss,ix);
7442 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7446 case SAVEt_SPTR: /* SV* reference */
7447 ptr = POPPTR(ss,ix);
7448 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7449 sv = (SV*)POPPTR(ss,ix);
7450 TOPPTR(nss,ix) = sv_dup(sv);
7452 case SAVEt_VPTR: /* random* reference */
7453 ptr = POPPTR(ss,ix);
7454 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7455 ptr = POPPTR(ss,ix);
7456 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7458 case SAVEt_PPTR: /* char* reference */
7459 ptr = POPPTR(ss,ix);
7460 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7461 c = (char*)POPPTR(ss,ix);
7462 TOPPTR(nss,ix) = pv_dup(c);
7464 case SAVEt_HPTR: /* HV* reference */
7465 ptr = POPPTR(ss,ix);
7466 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7467 hv = (HV*)POPPTR(ss,ix);
7468 TOPPTR(nss,ix) = hv_dup(hv);
7470 case SAVEt_APTR: /* AV* reference */
7471 ptr = POPPTR(ss,ix);
7472 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7473 av = (AV*)POPPTR(ss,ix);
7474 TOPPTR(nss,ix) = av_dup(av);
7477 gv = (GV*)POPPTR(ss,ix);
7478 TOPPTR(nss,ix) = gv_dup(gv);
7480 case SAVEt_GP: /* scalar reference */
7481 gp = (GP*)POPPTR(ss,ix);
7482 TOPPTR(nss,ix) = gp = gp_dup(gp);
7483 (void)GpREFCNT_inc(gp);
7484 gv = (GV*)POPPTR(ss,ix);
7485 TOPPTR(nss,ix) = gv_dup_inc(c);
7486 c = (char*)POPPTR(ss,ix);
7487 TOPPTR(nss,ix) = pv_dup(c);
7494 sv = (SV*)POPPTR(ss,ix);
7495 TOPPTR(nss,ix) = sv_dup_inc(sv);
7498 ptr = POPPTR(ss,ix);
7499 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7500 /* these are assumed to be refcounted properly */
7501 switch (((OP*)ptr)->op_type) {
7508 TOPPTR(nss,ix) = ptr;
7513 TOPPTR(nss,ix) = Nullop;
7518 TOPPTR(nss,ix) = Nullop;
7521 c = (char*)POPPTR(ss,ix);
7522 TOPPTR(nss,ix) = pv_dup_inc(c);
7525 longval = POPLONG(ss,ix);
7526 TOPLONG(nss,ix) = longval;
7529 hv = (HV*)POPPTR(ss,ix);
7530 TOPPTR(nss,ix) = hv_dup_inc(hv);
7531 c = (char*)POPPTR(ss,ix);
7532 TOPPTR(nss,ix) = pv_dup_inc(c);
7536 case SAVEt_DESTRUCTOR:
7537 ptr = POPPTR(ss,ix);
7538 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7539 dptr = POPDPTR(ss,ix);
7540 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7542 case SAVEt_DESTRUCTOR_X:
7543 ptr = POPPTR(ss,ix);
7544 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7545 dxptr = POPDXPTR(ss,ix);
7546 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7548 case SAVEt_REGCONTEXT:
7554 case SAVEt_STACK_POS: /* Position on Perl stack */
7558 case SAVEt_AELEM: /* array element */
7559 sv = (SV*)POPPTR(ss,ix);
7560 TOPPTR(nss,ix) = sv_dup_inc(sv);
7563 av = (AV*)POPPTR(ss,ix);
7564 TOPPTR(nss,ix) = av_dup_inc(av);
7566 case SAVEt_HELEM: /* hash element */
7567 sv = (SV*)POPPTR(ss,ix);
7568 TOPPTR(nss,ix) = sv_dup_inc(sv);
7569 sv = (SV*)POPPTR(ss,ix);
7570 TOPPTR(nss,ix) = sv_dup_inc(sv);
7571 hv = (HV*)POPPTR(ss,ix);
7572 TOPPTR(nss,ix) = hv_dup_inc(hv);
7575 ptr = POPPTR(ss,ix);
7576 TOPPTR(nss,ix) = ptr;
7583 av = (AV*)POPPTR(ss,ix);
7584 TOPPTR(nss,ix) = av_dup(av);
7587 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7599 perl_clone(PerlInterpreter *proto_perl, UV flags)
7602 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7605 #ifdef PERL_IMPLICIT_SYS
7606 return perl_clone_using(proto_perl, flags,
7608 proto_perl->IMemShared,
7609 proto_perl->IMemParse,
7619 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7620 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7621 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7622 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7623 struct IPerlDir* ipD, struct IPerlSock* ipS,
7624 struct IPerlProc* ipP)
7626 /* XXX many of the string copies here can be optimized if they're
7627 * constants; they need to be allocated as common memory and just
7628 * their pointers copied. */
7632 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7634 PERL_SET_THX(pPerl);
7635 # else /* !PERL_OBJECT */
7636 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7637 PERL_SET_THX(my_perl);
7640 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7645 # else /* !DEBUGGING */
7646 Zero(my_perl, 1, PerlInterpreter);
7647 # endif /* DEBUGGING */
7651 PL_MemShared = ipMS;
7659 # endif /* PERL_OBJECT */
7660 #else /* !PERL_IMPLICIT_SYS */
7662 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7663 PERL_SET_THX(my_perl);
7666 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7671 # else /* !DEBUGGING */
7672 Zero(my_perl, 1, PerlInterpreter);
7673 # endif /* DEBUGGING */
7674 #endif /* PERL_IMPLICIT_SYS */
7677 PL_xiv_arenaroot = NULL;
7679 PL_xnv_arenaroot = NULL;
7681 PL_xrv_arenaroot = NULL;
7683 PL_xpv_arenaroot = NULL;
7685 PL_xpviv_arenaroot = NULL;
7686 PL_xpviv_root = NULL;
7687 PL_xpvnv_arenaroot = NULL;
7688 PL_xpvnv_root = NULL;
7689 PL_xpvcv_arenaroot = NULL;
7690 PL_xpvcv_root = NULL;
7691 PL_xpvav_arenaroot = NULL;
7692 PL_xpvav_root = NULL;
7693 PL_xpvhv_arenaroot = NULL;
7694 PL_xpvhv_root = NULL;
7695 PL_xpvmg_arenaroot = NULL;
7696 PL_xpvmg_root = NULL;
7697 PL_xpvlv_arenaroot = NULL;
7698 PL_xpvlv_root = NULL;
7699 PL_xpvbm_arenaroot = NULL;
7700 PL_xpvbm_root = NULL;
7701 PL_he_arenaroot = NULL;
7703 PL_nice_chunk = NULL;
7704 PL_nice_chunk_size = 0;
7707 PL_sv_root = Nullsv;
7708 PL_sv_arenaroot = Nullsv;
7710 PL_debug = proto_perl->Idebug;
7712 /* create SV map for pointer relocation */
7713 PL_ptr_table = ptr_table_new();
7715 /* initialize these special pointers as early as possible */
7716 SvANY(&PL_sv_undef) = NULL;
7717 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7718 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7719 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7722 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7724 SvANY(&PL_sv_no) = new_XPVNV();
7726 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7727 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7728 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7729 SvCUR(&PL_sv_no) = 0;
7730 SvLEN(&PL_sv_no) = 1;
7731 SvNVX(&PL_sv_no) = 0;
7732 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7735 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7737 SvANY(&PL_sv_yes) = new_XPVNV();
7739 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7740 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7741 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7742 SvCUR(&PL_sv_yes) = 1;
7743 SvLEN(&PL_sv_yes) = 2;
7744 SvNVX(&PL_sv_yes) = 1;
7745 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7747 /* create shared string table */
7748 PL_strtab = newHV();
7749 HvSHAREKEYS_off(PL_strtab);
7750 hv_ksplit(PL_strtab, 512);
7751 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7753 PL_compiling = proto_perl->Icompiling;
7754 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7755 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7756 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7757 if (!specialWARN(PL_compiling.cop_warnings))
7758 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7759 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7761 /* pseudo environmental stuff */
7762 PL_origargc = proto_perl->Iorigargc;
7764 New(0, PL_origargv, i+1, char*);
7765 PL_origargv[i] = '\0';
7767 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7769 PL_envgv = gv_dup(proto_perl->Ienvgv);
7770 PL_incgv = gv_dup(proto_perl->Iincgv);
7771 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7772 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7773 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7774 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7777 PL_minus_c = proto_perl->Iminus_c;
7778 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7779 PL_localpatches = proto_perl->Ilocalpatches;
7780 PL_splitstr = proto_perl->Isplitstr;
7781 PL_preprocess = proto_perl->Ipreprocess;
7782 PL_minus_n = proto_perl->Iminus_n;
7783 PL_minus_p = proto_perl->Iminus_p;
7784 PL_minus_l = proto_perl->Iminus_l;
7785 PL_minus_a = proto_perl->Iminus_a;
7786 PL_minus_F = proto_perl->Iminus_F;
7787 PL_doswitches = proto_perl->Idoswitches;
7788 PL_dowarn = proto_perl->Idowarn;
7789 PL_doextract = proto_perl->Idoextract;
7790 PL_sawampersand = proto_perl->Isawampersand;
7791 PL_unsafe = proto_perl->Iunsafe;
7792 PL_inplace = SAVEPV(proto_perl->Iinplace);
7793 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7794 PL_perldb = proto_perl->Iperldb;
7795 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7797 /* magical thingies */
7798 /* XXX time(&PL_basetime) when asked for? */
7799 PL_basetime = proto_perl->Ibasetime;
7800 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7802 PL_maxsysfd = proto_perl->Imaxsysfd;
7803 PL_multiline = proto_perl->Imultiline;
7804 PL_statusvalue = proto_perl->Istatusvalue;
7806 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7809 /* shortcuts to various I/O objects */
7810 PL_stdingv = gv_dup(proto_perl->Istdingv);
7811 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7812 PL_defgv = gv_dup(proto_perl->Idefgv);
7813 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7814 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7815 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7817 /* shortcuts to regexp stuff */
7818 PL_replgv = gv_dup(proto_perl->Ireplgv);
7820 /* shortcuts to misc objects */
7821 PL_errgv = gv_dup(proto_perl->Ierrgv);
7823 /* shortcuts to debugging objects */
7824 PL_DBgv = gv_dup(proto_perl->IDBgv);
7825 PL_DBline = gv_dup(proto_perl->IDBline);
7826 PL_DBsub = gv_dup(proto_perl->IDBsub);
7827 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7828 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7829 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7830 PL_lineary = av_dup(proto_perl->Ilineary);
7831 PL_dbargs = av_dup(proto_perl->Idbargs);
7834 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7835 PL_curstash = hv_dup(proto_perl->Tcurstash);
7836 PL_debstash = hv_dup(proto_perl->Idebstash);
7837 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7838 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7840 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7841 PL_endav = av_dup_inc(proto_perl->Iendav);
7842 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7843 PL_initav = av_dup_inc(proto_perl->Iinitav);
7845 PL_sub_generation = proto_perl->Isub_generation;
7847 /* funky return mechanisms */
7848 PL_forkprocess = proto_perl->Iforkprocess;
7850 /* subprocess state */
7851 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7853 /* internal state */
7854 PL_tainting = proto_perl->Itainting;
7855 PL_maxo = proto_perl->Imaxo;
7856 if (proto_perl->Iop_mask)
7857 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7859 PL_op_mask = Nullch;
7861 /* current interpreter roots */
7862 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7863 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7864 PL_main_start = proto_perl->Imain_start;
7865 PL_eval_root = proto_perl->Ieval_root;
7866 PL_eval_start = proto_perl->Ieval_start;
7868 /* runtime control stuff */
7869 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7870 PL_copline = proto_perl->Icopline;
7872 PL_filemode = proto_perl->Ifilemode;
7873 PL_lastfd = proto_perl->Ilastfd;
7874 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7877 PL_gensym = proto_perl->Igensym;
7878 PL_preambled = proto_perl->Ipreambled;
7879 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7880 PL_laststatval = proto_perl->Ilaststatval;
7881 PL_laststype = proto_perl->Ilaststype;
7882 PL_mess_sv = Nullsv;
7884 PL_orslen = proto_perl->Iorslen;
7885 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7886 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7888 /* interpreter atexit processing */
7889 PL_exitlistlen = proto_perl->Iexitlistlen;
7890 if (PL_exitlistlen) {
7891 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7892 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7895 PL_exitlist = (PerlExitListEntry*)NULL;
7896 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7898 PL_profiledata = NULL;
7899 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7900 /* PL_rsfp_filters entries have fake IoDIRP() */
7901 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7903 PL_compcv = cv_dup(proto_perl->Icompcv);
7904 PL_comppad = av_dup(proto_perl->Icomppad);
7905 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7906 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7907 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7908 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7909 proto_perl->Tcurpad);
7911 #ifdef HAVE_INTERP_INTERN
7912 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7915 /* more statics moved here */
7916 PL_generation = proto_perl->Igeneration;
7917 PL_DBcv = cv_dup(proto_perl->IDBcv);
7919 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7920 PL_in_clean_all = proto_perl->Iin_clean_all;
7922 PL_uid = proto_perl->Iuid;
7923 PL_euid = proto_perl->Ieuid;
7924 PL_gid = proto_perl->Igid;
7925 PL_egid = proto_perl->Iegid;
7926 PL_nomemok = proto_perl->Inomemok;
7927 PL_an = proto_perl->Ian;
7928 PL_cop_seqmax = proto_perl->Icop_seqmax;
7929 PL_op_seqmax = proto_perl->Iop_seqmax;
7930 PL_evalseq = proto_perl->Ievalseq;
7931 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7932 PL_origalen = proto_perl->Iorigalen;
7933 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7934 PL_osname = SAVEPV(proto_perl->Iosname);
7935 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7936 PL_sighandlerp = proto_perl->Isighandlerp;
7939 PL_runops = proto_perl->Irunops;
7941 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7944 PL_cshlen = proto_perl->Icshlen;
7945 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7948 PL_lex_state = proto_perl->Ilex_state;
7949 PL_lex_defer = proto_perl->Ilex_defer;
7950 PL_lex_expect = proto_perl->Ilex_expect;
7951 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7952 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7953 PL_lex_starts = proto_perl->Ilex_starts;
7954 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7955 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7956 PL_lex_op = proto_perl->Ilex_op;
7957 PL_lex_inpat = proto_perl->Ilex_inpat;
7958 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7959 PL_lex_brackets = proto_perl->Ilex_brackets;
7960 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7961 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7962 PL_lex_casemods = proto_perl->Ilex_casemods;
7963 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7964 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7966 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7967 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7968 PL_nexttoke = proto_perl->Inexttoke;
7970 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7971 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7972 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7973 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7974 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7975 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7976 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7977 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7978 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7979 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7980 PL_pending_ident = proto_perl->Ipending_ident;
7981 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7983 PL_expect = proto_perl->Iexpect;
7985 PL_multi_start = proto_perl->Imulti_start;
7986 PL_multi_end = proto_perl->Imulti_end;
7987 PL_multi_open = proto_perl->Imulti_open;
7988 PL_multi_close = proto_perl->Imulti_close;
7990 PL_error_count = proto_perl->Ierror_count;
7991 PL_subline = proto_perl->Isubline;
7992 PL_subname = sv_dup_inc(proto_perl->Isubname);
7994 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7995 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7996 PL_padix = proto_perl->Ipadix;
7997 PL_padix_floor = proto_perl->Ipadix_floor;
7998 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8000 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8001 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8002 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8003 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8004 PL_last_lop_op = proto_perl->Ilast_lop_op;
8005 PL_in_my = proto_perl->Iin_my;
8006 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8008 PL_cryptseen = proto_perl->Icryptseen;
8011 PL_hints = proto_perl->Ihints;
8013 PL_amagic_generation = proto_perl->Iamagic_generation;
8015 #ifdef USE_LOCALE_COLLATE
8016 PL_collation_ix = proto_perl->Icollation_ix;
8017 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8018 PL_collation_standard = proto_perl->Icollation_standard;
8019 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8020 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8021 #endif /* USE_LOCALE_COLLATE */
8023 #ifdef USE_LOCALE_NUMERIC
8024 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8025 PL_numeric_standard = proto_perl->Inumeric_standard;
8026 PL_numeric_local = proto_perl->Inumeric_local;
8027 PL_numeric_radix = proto_perl->Inumeric_radix;
8028 #endif /* !USE_LOCALE_NUMERIC */
8030 /* utf8 character classes */
8031 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8032 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8033 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8034 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8035 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8036 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8037 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8038 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8039 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8040 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8041 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8042 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8043 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8044 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8045 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8046 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8047 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8050 PL_last_swash_hv = Nullhv; /* reinits on demand */
8051 PL_last_swash_klen = 0;
8052 PL_last_swash_key[0]= '\0';
8053 PL_last_swash_tmps = (U8*)NULL;
8054 PL_last_swash_slen = 0;
8056 /* perly.c globals */
8057 PL_yydebug = proto_perl->Iyydebug;
8058 PL_yynerrs = proto_perl->Iyynerrs;
8059 PL_yyerrflag = proto_perl->Iyyerrflag;
8060 PL_yychar = proto_perl->Iyychar;
8061 PL_yyval = proto_perl->Iyyval;
8062 PL_yylval = proto_perl->Iyylval;
8064 PL_glob_index = proto_perl->Iglob_index;
8065 PL_srand_called = proto_perl->Isrand_called;
8066 PL_uudmap['M'] = 0; /* reinits on demand */
8067 PL_bitcount = Nullch; /* reinits on demand */
8069 if (proto_perl->Ipsig_ptr) {
8070 int sig_num[] = { SIG_NUM };
8071 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8072 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8073 for (i = 1; PL_sig_name[i]; i++) {
8074 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8075 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8079 PL_psig_ptr = (SV**)NULL;
8080 PL_psig_name = (SV**)NULL;
8083 /* thrdvar.h stuff */
8086 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8087 PL_tmps_ix = proto_perl->Ttmps_ix;
8088 PL_tmps_max = proto_perl->Ttmps_max;
8089 PL_tmps_floor = proto_perl->Ttmps_floor;
8090 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8092 while (i <= PL_tmps_ix) {
8093 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8097 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8098 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8099 Newz(54, PL_markstack, i, I32);
8100 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8101 - proto_perl->Tmarkstack);
8102 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8103 - proto_perl->Tmarkstack);
8104 Copy(proto_perl->Tmarkstack, PL_markstack,
8105 PL_markstack_ptr - PL_markstack + 1, I32);
8107 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8108 * NOTE: unlike the others! */
8109 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8110 PL_scopestack_max = proto_perl->Tscopestack_max;
8111 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8112 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8114 /* next push_return() sets PL_retstack[PL_retstack_ix]
8115 * NOTE: unlike the others! */
8116 PL_retstack_ix = proto_perl->Tretstack_ix;
8117 PL_retstack_max = proto_perl->Tretstack_max;
8118 Newz(54, PL_retstack, PL_retstack_max, OP*);
8119 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8121 /* NOTE: si_dup() looks at PL_markstack */
8122 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8124 /* PL_curstack = PL_curstackinfo->si_stack; */
8125 PL_curstack = av_dup(proto_perl->Tcurstack);
8126 PL_mainstack = av_dup(proto_perl->Tmainstack);
8128 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8129 PL_stack_base = AvARRAY(PL_curstack);
8130 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8131 - proto_perl->Tstack_base);
8132 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8134 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8135 * NOTE: unlike the others! */
8136 PL_savestack_ix = proto_perl->Tsavestack_ix;
8137 PL_savestack_max = proto_perl->Tsavestack_max;
8138 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8139 PL_savestack = ss_dup(proto_perl);
8143 ENTER; /* perl_destruct() wants to LEAVE; */
8146 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8147 PL_top_env = &PL_start_env;
8149 PL_op = proto_perl->Top;
8152 PL_Xpv = (XPV*)NULL;
8153 PL_na = proto_perl->Tna;
8155 PL_statbuf = proto_perl->Tstatbuf;
8156 PL_statcache = proto_perl->Tstatcache;
8157 PL_statgv = gv_dup(proto_perl->Tstatgv);
8158 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8160 PL_timesbuf = proto_perl->Ttimesbuf;
8163 PL_tainted = proto_perl->Ttainted;
8164 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8165 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8166 PL_rs = sv_dup_inc(proto_perl->Trs);
8167 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8168 PL_ofslen = proto_perl->Tofslen;
8169 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8170 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8171 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8172 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8173 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8174 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8176 PL_restartop = proto_perl->Trestartop;
8177 PL_in_eval = proto_perl->Tin_eval;
8178 PL_delaymagic = proto_perl->Tdelaymagic;
8179 PL_dirty = proto_perl->Tdirty;
8180 PL_localizing = proto_perl->Tlocalizing;
8182 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8183 PL_protect = proto_perl->Tprotect;
8185 PL_errors = sv_dup_inc(proto_perl->Terrors);
8186 PL_av_fetch_sv = Nullsv;
8187 PL_hv_fetch_sv = Nullsv;
8188 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8189 PL_modcount = proto_perl->Tmodcount;
8190 PL_lastgotoprobe = Nullop;
8191 PL_dumpindent = proto_perl->Tdumpindent;
8193 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8194 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8195 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8196 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8197 PL_sortcxix = proto_perl->Tsortcxix;
8198 PL_efloatbuf = Nullch; /* reinits on demand */
8199 PL_efloatsize = 0; /* reinits on demand */
8203 PL_screamfirst = NULL;
8204 PL_screamnext = NULL;
8205 PL_maxscream = -1; /* reinits on demand */
8206 PL_lastscream = Nullsv;
8208 PL_watchaddr = NULL;
8209 PL_watchok = Nullch;
8211 PL_regdummy = proto_perl->Tregdummy;
8212 PL_regcomp_parse = Nullch;
8213 PL_regxend = Nullch;
8214 PL_regcode = (regnode*)NULL;
8217 PL_regprecomp = Nullch;
8222 PL_seen_zerolen = 0;
8224 PL_regcomp_rx = (regexp*)NULL;
8226 PL_colorset = 0; /* reinits PL_colors[] */
8227 /*PL_colors[6] = {0,0,0,0,0,0};*/
8228 PL_reg_whilem_seen = 0;
8229 PL_reginput = Nullch;
8232 PL_regstartp = (I32*)NULL;
8233 PL_regendp = (I32*)NULL;
8234 PL_reglastparen = (U32*)NULL;
8235 PL_regtill = Nullch;
8237 PL_reg_start_tmp = (char**)NULL;
8238 PL_reg_start_tmpl = 0;
8239 PL_regdata = (struct reg_data*)NULL;
8242 PL_reg_eval_set = 0;
8244 PL_regprogram = (regnode*)NULL;
8246 PL_regcc = (CURCUR*)NULL;
8247 PL_reg_call_cc = (struct re_cc_state*)NULL;
8248 PL_reg_re = (regexp*)NULL;
8249 PL_reg_ganch = Nullch;
8251 PL_reg_magic = (MAGIC*)NULL;
8253 PL_reg_oldcurpm = (PMOP*)NULL;
8254 PL_reg_curpm = (PMOP*)NULL;
8255 PL_reg_oldsaved = Nullch;
8256 PL_reg_oldsavedlen = 0;
8258 PL_reg_leftiter = 0;
8259 PL_reg_poscache = Nullch;
8260 PL_reg_poscache_size= 0;
8262 /* RE engine - function pointers */
8263 PL_regcompp = proto_perl->Tregcompp;
8264 PL_regexecp = proto_perl->Tregexecp;
8265 PL_regint_start = proto_perl->Tregint_start;
8266 PL_regint_string = proto_perl->Tregint_string;
8267 PL_regfree = proto_perl->Tregfree;
8269 PL_reginterp_cnt = 0;
8270 PL_reg_starttry = 0;
8273 return (PerlInterpreter*)pPerl;
8279 #else /* !USE_ITHREADS */
8285 #endif /* USE_ITHREADS */
8288 do_report_used(pTHXo_ SV *sv)
8290 if (SvTYPE(sv) != SVTYPEMASK) {
8291 PerlIO_printf(Perl_debug_log, "****\n");
8297 do_clean_objs(pTHXo_ SV *sv)
8301 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8302 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8308 /* XXX Might want to check arrays, etc. */
8311 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8313 do_clean_named_objs(pTHXo_ SV *sv)
8315 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8316 if ( SvOBJECT(GvSV(sv)) ||
8317 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8318 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8319 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8320 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8322 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8330 do_clean_all(pTHXo_ SV *sv)
8332 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8333 SvFLAGS(sv) |= SVf_BREAK;