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(GvSV(dstr));
2838 dref = (SV*)GvSV(dstr);
2840 if (!GvIMPORTED_SV(dstr)
2841 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2843 GvIMPORTED_SV_on(dstr);
2855 (void)SvOOK_off(dstr); /* backoff */
2857 Safefree(SvPVX(dstr));
2858 SvLEN(dstr)=SvCUR(dstr)=0;
2861 (void)SvOK_off(dstr);
2862 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2864 if (sflags & SVp_NOK) {
2866 SvNVX(dstr) = SvNVX(sstr);
2868 if (sflags & SVp_IOK) {
2869 (void)SvIOK_on(dstr);
2870 SvIVX(dstr) = SvIVX(sstr);
2871 if (sflags & SVf_IVisUV)
2874 if (SvAMAGIC(sstr)) {
2878 else if (sflags & SVp_POK) {
2881 * Check to see if we can just swipe the string. If so, it's a
2882 * possible small lose on short strings, but a big win on long ones.
2883 * It might even be a win on short strings if SvPVX(dstr)
2884 * has to be allocated and SvPVX(sstr) has to be freed.
2887 if (SvTEMP(sstr) && /* slated for free anyway? */
2888 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2889 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2891 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2893 SvFLAGS(dstr) &= ~SVf_OOK;
2894 Safefree(SvPVX(dstr) - SvIVX(dstr));
2896 else if (SvLEN(dstr))
2897 Safefree(SvPVX(dstr));
2899 (void)SvPOK_only(dstr);
2900 SvPV_set(dstr, SvPVX(sstr));
2901 SvLEN_set(dstr, SvLEN(sstr));
2902 SvCUR_set(dstr, SvCUR(sstr));
2905 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
2906 SvPV_set(sstr, Nullch);
2911 else { /* have to copy actual string */
2912 STRLEN len = SvCUR(sstr);
2914 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2915 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2916 SvCUR_set(dstr, len);
2917 *SvEND(dstr) = '\0';
2918 (void)SvPOK_only(dstr);
2920 if ((sflags & SVf_UTF8) && !IN_BYTE)
2923 if (sflags & SVp_NOK) {
2925 SvNVX(dstr) = SvNVX(sstr);
2927 if (sflags & SVp_IOK) {
2928 (void)SvIOK_on(dstr);
2929 SvIVX(dstr) = SvIVX(sstr);
2930 if (sflags & SVf_IVisUV)
2934 else if (sflags & SVp_NOK) {
2935 SvNVX(dstr) = SvNVX(sstr);
2936 (void)SvNOK_only(dstr);
2937 if (sflags & SVf_IOK) {
2938 (void)SvIOK_on(dstr);
2939 SvIVX(dstr) = SvIVX(sstr);
2940 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2941 if (sflags & SVf_IVisUV)
2945 else if (sflags & SVp_IOK) {
2946 (void)SvIOK_only(dstr);
2947 SvIVX(dstr) = SvIVX(sstr);
2948 if (sflags & SVf_IVisUV)
2952 if (dtype == SVt_PVGV) {
2953 if (ckWARN(WARN_MISC))
2954 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2957 (void)SvOK_off(dstr);
2963 =for apidoc sv_setsv_mg
2965 Like C<sv_setsv>, but also handles 'set' magic.
2971 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2973 sv_setsv(dstr,sstr);
2978 =for apidoc sv_setpvn
2980 Copies a string into an SV. The C<len> parameter indicates the number of
2981 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2987 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2989 register char *dptr;
2990 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2991 elicit a warning, but it won't hurt. */
2992 SV_CHECK_THINKFIRST(sv);
2997 (void)SvUPGRADE(sv, SVt_PV);
2999 SvGROW(sv, len + 1);
3001 Move(ptr,dptr,len,char);
3004 (void)SvPOK_only(sv); /* validate pointer */
3009 =for apidoc sv_setpvn_mg
3011 Like C<sv_setpvn>, but also handles 'set' magic.
3017 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3019 sv_setpvn(sv,ptr,len);
3024 =for apidoc sv_setpv
3026 Copies a string into an SV. The string must be null-terminated. Does not
3027 handle 'set' magic. See C<sv_setpv_mg>.
3033 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3035 register STRLEN len;
3037 SV_CHECK_THINKFIRST(sv);
3043 (void)SvUPGRADE(sv, SVt_PV);
3045 SvGROW(sv, len + 1);
3046 Move(ptr,SvPVX(sv),len+1,char);
3048 (void)SvPOK_only(sv); /* validate pointer */
3053 =for apidoc sv_setpv_mg
3055 Like C<sv_setpv>, but also handles 'set' magic.
3061 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3068 =for apidoc sv_usepvn
3070 Tells an SV to use C<ptr> to find its string value. Normally the string is
3071 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3072 The C<ptr> should point to memory that was allocated by C<malloc>. The
3073 string length, C<len>, must be supplied. This function will realloc the
3074 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3075 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3076 See C<sv_usepvn_mg>.
3082 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3084 SV_CHECK_THINKFIRST(sv);
3085 (void)SvUPGRADE(sv, SVt_PV);
3090 (void)SvOOK_off(sv);
3091 if (SvPVX(sv) && SvLEN(sv))
3092 Safefree(SvPVX(sv));
3093 Renew(ptr, len+1, char);
3096 SvLEN_set(sv, len+1);
3098 (void)SvPOK_only(sv); /* validate pointer */
3103 =for apidoc sv_usepvn_mg
3105 Like C<sv_usepvn>, but also handles 'set' magic.
3111 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3113 sv_usepvn(sv,ptr,len);
3118 Perl_sv_force_normal(pTHX_ register SV *sv)
3120 if (SvREADONLY(sv)) {
3122 if (PL_curcop != &PL_compiling)
3123 Perl_croak(aTHX_ PL_no_modify);
3127 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3134 Efficient removal of characters from the beginning of the string buffer.
3135 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3136 the string buffer. The C<ptr> becomes the first character of the adjusted
3143 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3147 register STRLEN delta;
3149 if (!ptr || !SvPOKp(sv))
3151 SV_CHECK_THINKFIRST(sv);
3152 if (SvTYPE(sv) < SVt_PVIV)
3153 sv_upgrade(sv,SVt_PVIV);
3156 if (!SvLEN(sv)) { /* make copy of shared string */
3157 char *pvx = SvPVX(sv);
3158 STRLEN len = SvCUR(sv);
3159 SvGROW(sv, len + 1);
3160 Move(pvx,SvPVX(sv),len,char);
3164 SvFLAGS(sv) |= SVf_OOK;
3166 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3167 delta = ptr - SvPVX(sv);
3175 =for apidoc sv_catpvn
3177 Concatenates the string onto the end of the string which is in the SV. The
3178 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3179 'set' magic. See C<sv_catpvn_mg>.
3185 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3190 junk = SvPV_force(sv, tlen);
3191 SvGROW(sv, tlen + len + 1);
3194 Move(ptr,SvPVX(sv)+tlen,len,char);
3197 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3202 =for apidoc sv_catpvn_mg
3204 Like C<sv_catpvn>, but also handles 'set' magic.
3210 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3212 sv_catpvn(sv,ptr,len);
3217 =for apidoc sv_catsv
3219 Concatenates the string from SV C<ssv> onto the end of the string in SV
3220 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3226 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3232 if ((s = SvPV(sstr, len))) {
3233 if (DO_UTF8(sstr)) {
3234 sv_utf8_upgrade(dstr);
3235 sv_catpvn(dstr,s,len);
3239 sv_catpvn(dstr,s,len);
3244 =for apidoc sv_catsv_mg
3246 Like C<sv_catsv>, but also handles 'set' magic.
3252 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3254 sv_catsv(dstr,sstr);
3259 =for apidoc sv_catpv
3261 Concatenates the string onto the end of the string which is in the SV.
3262 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3268 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3270 register STRLEN len;
3276 junk = SvPV_force(sv, tlen);
3278 SvGROW(sv, tlen + len + 1);
3281 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3283 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3288 =for apidoc sv_catpv_mg
3290 Like C<sv_catpv>, but also handles 'set' magic.
3296 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3303 Perl_newSV(pTHX_ STRLEN len)
3309 sv_upgrade(sv, SVt_PV);
3310 SvGROW(sv, len + 1);
3315 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3318 =for apidoc sv_magic
3320 Adds magic to an SV.
3326 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3330 if (SvREADONLY(sv)) {
3332 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3333 Perl_croak(aTHX_ PL_no_modify);
3335 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3336 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3343 (void)SvUPGRADE(sv, SVt_PVMG);
3345 Newz(702,mg, 1, MAGIC);
3346 mg->mg_moremagic = SvMAGIC(sv);
3349 if (!obj || obj == sv || how == '#' || how == 'r')
3353 mg->mg_obj = SvREFCNT_inc(obj);
3354 mg->mg_flags |= MGf_REFCOUNTED;
3357 mg->mg_len = namlen;
3360 mg->mg_ptr = savepvn(name, namlen);
3361 else if (namlen == HEf_SVKEY)
3362 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3366 mg->mg_virtual = &PL_vtbl_sv;
3369 mg->mg_virtual = &PL_vtbl_amagic;
3372 mg->mg_virtual = &PL_vtbl_amagicelem;
3378 mg->mg_virtual = &PL_vtbl_bm;
3381 mg->mg_virtual = &PL_vtbl_regdata;
3384 mg->mg_virtual = &PL_vtbl_regdatum;
3387 mg->mg_virtual = &PL_vtbl_env;
3390 mg->mg_virtual = &PL_vtbl_fm;
3393 mg->mg_virtual = &PL_vtbl_envelem;
3396 mg->mg_virtual = &PL_vtbl_mglob;
3399 mg->mg_virtual = &PL_vtbl_isa;
3402 mg->mg_virtual = &PL_vtbl_isaelem;
3405 mg->mg_virtual = &PL_vtbl_nkeys;
3412 mg->mg_virtual = &PL_vtbl_dbline;
3416 mg->mg_virtual = &PL_vtbl_mutex;
3418 #endif /* USE_THREADS */
3419 #ifdef USE_LOCALE_COLLATE
3421 mg->mg_virtual = &PL_vtbl_collxfrm;
3423 #endif /* USE_LOCALE_COLLATE */
3425 mg->mg_virtual = &PL_vtbl_pack;
3429 mg->mg_virtual = &PL_vtbl_packelem;
3432 mg->mg_virtual = &PL_vtbl_regexp;
3435 mg->mg_virtual = &PL_vtbl_sig;
3438 mg->mg_virtual = &PL_vtbl_sigelem;
3441 mg->mg_virtual = &PL_vtbl_taint;
3445 mg->mg_virtual = &PL_vtbl_uvar;
3448 mg->mg_virtual = &PL_vtbl_vec;
3451 mg->mg_virtual = &PL_vtbl_substr;
3454 mg->mg_virtual = &PL_vtbl_defelem;
3457 mg->mg_virtual = &PL_vtbl_glob;
3460 mg->mg_virtual = &PL_vtbl_arylen;
3463 mg->mg_virtual = &PL_vtbl_pos;
3466 mg->mg_virtual = &PL_vtbl_backref;
3468 case '~': /* Reserved for use by extensions not perl internals. */
3469 /* Useful for attaching extension internal data to perl vars. */
3470 /* Note that multiple extensions may clash if magical scalars */
3471 /* etc holding private data from one are passed to another. */
3475 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3479 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3483 =for apidoc sv_unmagic
3485 Removes magic from an SV.
3491 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3495 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3498 for (mg = *mgp; mg; mg = *mgp) {
3499 if (mg->mg_type == type) {
3500 MGVTBL* vtbl = mg->mg_virtual;
3501 *mgp = mg->mg_moremagic;
3502 if (vtbl && vtbl->svt_free)
3503 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3504 if (mg->mg_ptr && mg->mg_type != 'g')
3505 if (mg->mg_len >= 0)
3506 Safefree(mg->mg_ptr);
3507 else if (mg->mg_len == HEf_SVKEY)
3508 SvREFCNT_dec((SV*)mg->mg_ptr);
3509 if (mg->mg_flags & MGf_REFCOUNTED)
3510 SvREFCNT_dec(mg->mg_obj);
3514 mgp = &mg->mg_moremagic;
3518 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3525 =for apidoc sv_rvweaken
3533 Perl_sv_rvweaken(pTHX_ SV *sv)
3536 if (!SvOK(sv)) /* let undefs pass */
3539 Perl_croak(aTHX_ "Can't weaken a nonreference");
3540 else if (SvWEAKREF(sv)) {
3542 if (ckWARN(WARN_MISC))
3543 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3547 sv_add_backref(tsv, sv);
3554 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3558 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3559 av = (AV*)mg->mg_obj;
3562 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3563 SvREFCNT_dec(av); /* for sv_magic */
3569 S_sv_del_backref(pTHX_ SV *sv)
3576 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3577 Perl_croak(aTHX_ "panic: del_backref");
3578 av = (AV *)mg->mg_obj;
3583 svp[i] = &PL_sv_undef; /* XXX */
3590 =for apidoc sv_insert
3592 Inserts a string at the specified offset/length within the SV. Similar to
3593 the Perl substr() function.
3599 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3603 register char *midend;
3604 register char *bigend;
3610 Perl_croak(aTHX_ "Can't modify non-existent substring");
3611 SvPV_force(bigstr, curlen);
3612 (void)SvPOK_only_UTF8(bigstr);
3613 if (offset + len > curlen) {
3614 SvGROW(bigstr, offset+len+1);
3615 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3616 SvCUR_set(bigstr, offset+len);
3620 i = littlelen - len;
3621 if (i > 0) { /* string might grow */
3622 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3623 mid = big + offset + len;
3624 midend = bigend = big + SvCUR(bigstr);
3627 while (midend > mid) /* shove everything down */
3628 *--bigend = *--midend;
3629 Move(little,big+offset,littlelen,char);
3635 Move(little,SvPVX(bigstr)+offset,len,char);
3640 big = SvPVX(bigstr);
3643 bigend = big + SvCUR(bigstr);
3645 if (midend > bigend)
3646 Perl_croak(aTHX_ "panic: sv_insert");
3648 if (mid - big > bigend - midend) { /* faster to shorten from end */
3650 Move(little, mid, littlelen,char);
3653 i = bigend - midend;
3655 Move(midend, mid, i,char);
3659 SvCUR_set(bigstr, mid - big);
3662 else if ((i = mid - big)) { /* faster from front */
3663 midend -= littlelen;
3665 sv_chop(bigstr,midend-i);
3670 Move(little, mid, littlelen,char);
3672 else if (littlelen) {
3673 midend -= littlelen;
3674 sv_chop(bigstr,midend);
3675 Move(little,midend,littlelen,char);
3678 sv_chop(bigstr,midend);
3684 =for apidoc sv_replace
3686 Make the first argument a copy of the second, then delete the original.
3692 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3695 U32 refcnt = SvREFCNT(sv);
3696 SV_CHECK_THINKFIRST(sv);
3697 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3698 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3699 if (SvMAGICAL(sv)) {
3703 sv_upgrade(nsv, SVt_PVMG);
3704 SvMAGIC(nsv) = SvMAGIC(sv);
3705 SvFLAGS(nsv) |= SvMAGICAL(sv);
3711 assert(!SvREFCNT(sv));
3712 StructCopy(nsv,sv,SV);
3713 SvREFCNT(sv) = refcnt;
3714 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3719 =for apidoc sv_clear
3721 Clear an SV, making it empty. Does not free the memory used by the SV
3728 Perl_sv_clear(pTHX_ register SV *sv)
3732 assert(SvREFCNT(sv) == 0);
3736 if (PL_defstash) { /* Still have a symbol table? */
3741 Zero(&tmpref, 1, SV);
3742 sv_upgrade(&tmpref, SVt_RV);
3744 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3745 SvREFCNT(&tmpref) = 1;
3748 stash = SvSTASH(sv);
3749 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3752 PUSHSTACKi(PERLSI_DESTROY);
3753 SvRV(&tmpref) = SvREFCNT_inc(sv);
3758 call_sv((SV*)GvCV(destructor),
3759 G_DISCARD|G_EVAL|G_KEEPERR);
3765 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3767 del_XRV(SvANY(&tmpref));
3770 if (PL_in_clean_objs)
3771 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3773 /* DESTROY gave object new lease on life */
3779 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3780 SvOBJECT_off(sv); /* Curse the object. */
3781 if (SvTYPE(sv) != SVt_PVIO)
3782 --PL_sv_objcount; /* XXX Might want something more general */
3785 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3788 switch (SvTYPE(sv)) {
3791 IoIFP(sv) != PerlIO_stdin() &&
3792 IoIFP(sv) != PerlIO_stdout() &&
3793 IoIFP(sv) != PerlIO_stderr())
3795 io_close((IO*)sv, FALSE);
3797 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3798 PerlDir_close(IoDIRP(sv));
3799 IoDIRP(sv) = (DIR*)NULL;
3800 Safefree(IoTOP_NAME(sv));
3801 Safefree(IoFMT_NAME(sv));
3802 Safefree(IoBOTTOM_NAME(sv));
3817 SvREFCNT_dec(LvTARG(sv));
3821 Safefree(GvNAME(sv));
3822 /* cannot decrease stash refcount yet, as we might recursively delete
3823 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3824 of stash until current sv is completely gone.
3825 -- JohnPC, 27 Mar 1998 */
3826 stash = GvSTASH(sv);
3832 (void)SvOOK_off(sv);
3840 SvREFCNT_dec(SvRV(sv));
3842 else if (SvPVX(sv) && SvLEN(sv))
3843 Safefree(SvPVX(sv));
3853 switch (SvTYPE(sv)) {
3869 del_XPVIV(SvANY(sv));
3872 del_XPVNV(SvANY(sv));
3875 del_XPVMG(SvANY(sv));
3878 del_XPVLV(SvANY(sv));
3881 del_XPVAV(SvANY(sv));
3884 del_XPVHV(SvANY(sv));
3887 del_XPVCV(SvANY(sv));
3890 del_XPVGV(SvANY(sv));
3891 /* code duplication for increased performance. */
3892 SvFLAGS(sv) &= SVf_BREAK;
3893 SvFLAGS(sv) |= SVTYPEMASK;
3894 /* decrease refcount of the stash that owns this GV, if any */
3896 SvREFCNT_dec(stash);
3897 return; /* not break, SvFLAGS reset already happened */
3899 del_XPVBM(SvANY(sv));
3902 del_XPVFM(SvANY(sv));
3905 del_XPVIO(SvANY(sv));
3908 SvFLAGS(sv) &= SVf_BREAK;
3909 SvFLAGS(sv) |= SVTYPEMASK;
3913 Perl_sv_newref(pTHX_ SV *sv)
3916 ATOMIC_INC(SvREFCNT(sv));
3923 Free the memory used by an SV.
3929 Perl_sv_free(pTHX_ SV *sv)
3932 int refcount_is_zero;
3936 if (SvREFCNT(sv) == 0) {
3937 if (SvFLAGS(sv) & SVf_BREAK)
3939 if (PL_in_clean_all) /* All is fair */
3941 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3942 /* make sure SvREFCNT(sv)==0 happens very seldom */
3943 SvREFCNT(sv) = (~(U32)0)/2;
3946 if (ckWARN_d(WARN_INTERNAL))
3947 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3950 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3951 if (!refcount_is_zero)
3955 if (ckWARN_d(WARN_DEBUGGING))
3956 Perl_warner(aTHX_ WARN_DEBUGGING,
3957 "Attempt to free temp prematurely: SV 0x%"UVxf,
3962 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3963 /* make sure SvREFCNT(sv)==0 happens very seldom */
3964 SvREFCNT(sv) = (~(U32)0)/2;
3975 Returns the length of the string in the SV. See also C<SvCUR>.
3981 Perl_sv_len(pTHX_ register SV *sv)
3990 len = mg_length(sv);
3992 junk = SvPV(sv, len);
3997 =for apidoc sv_len_utf8
3999 Returns the number of characters in the string in an SV, counting wide
4000 UTF8 bytes as a single character.
4006 Perl_sv_len_utf8(pTHX_ register SV *sv)
4017 len = mg_length(sv);
4020 s = (U8*)SvPV(sv, len);
4031 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4036 I32 uoffset = *offsetp;
4042 start = s = (U8*)SvPV(sv, len);
4044 while (s < send && uoffset--)
4048 *offsetp = s - start;
4052 while (s < send && ulen--)
4062 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4071 s = (U8*)SvPV(sv, len);
4073 Perl_croak(aTHX_ "panic: bad byte offset");
4074 send = s + *offsetp;
4082 if (ckWARN_d(WARN_UTF8))
4083 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4093 Returns a boolean indicating whether the strings in the two SVs are
4100 Perl_sv_eq(pTHX_ register SV *str1, register SV *str2)
4112 pv1 = SvPV(str1, cur1);
4117 if (SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
4119 sv_utf8_upgrade(str2);
4122 sv_utf8_upgrade(str1);
4126 pv2 = SvPV(str2, cur2);
4131 return memEQ(pv1, pv2, cur1);
4137 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4138 string in C<sv1> is less than, equal to, or greater than the string in
4145 Perl_sv_cmp(pTHX_ register SV *str1, register SV *str2)
4152 pv1 = SvPV(str1, cur1);
4160 if (SvPOK(str1) && SvUTF8(str1) != SvUTF8(str2) && !IN_BYTE) {
4161 /* must upgrade other to UTF8 first */
4163 sv_utf8_upgrade(str2);
4166 sv_utf8_upgrade(str1);
4167 /* refresh pointer and length */
4176 pv2 = sv_2pv(str2, &cur2);
4184 return cur2 ? -1 : 0;
4189 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4192 return retval < 0 ? -1 : 1;
4197 return cur1 < cur2 ? -1 : 1;
4201 =for apidoc sv_cmp_locale
4203 Compares the strings in two SVs in a locale-aware manner. See
4210 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4212 #ifdef USE_LOCALE_COLLATE
4218 if (PL_collation_standard)
4222 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4224 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4226 if (!pv1 || !len1) {
4237 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4240 return retval < 0 ? -1 : 1;
4243 * When the result of collation is equality, that doesn't mean
4244 * that there are no differences -- some locales exclude some
4245 * characters from consideration. So to avoid false equalities,
4246 * we use the raw string as a tiebreaker.
4252 #endif /* USE_LOCALE_COLLATE */
4254 return sv_cmp(sv1, sv2);
4257 #ifdef USE_LOCALE_COLLATE
4259 * Any scalar variable may carry an 'o' magic that contains the
4260 * scalar data of the variable transformed to such a format that
4261 * a normal memory comparison can be used to compare the data
4262 * according to the locale settings.
4265 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4269 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4270 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4275 Safefree(mg->mg_ptr);
4277 if ((xf = mem_collxfrm(s, len, &xlen))) {
4278 if (SvREADONLY(sv)) {
4281 return xf + sizeof(PL_collation_ix);
4284 sv_magic(sv, 0, 'o', 0, 0);
4285 mg = mg_find(sv, 'o');
4298 if (mg && mg->mg_ptr) {
4300 return mg->mg_ptr + sizeof(PL_collation_ix);
4308 #endif /* USE_LOCALE_COLLATE */
4313 Get a line from the filehandle and store it into the SV, optionally
4314 appending to the currently-stored string.
4320 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4325 register STDCHAR rslast;
4326 register STDCHAR *bp;
4330 SV_CHECK_THINKFIRST(sv);
4331 (void)SvUPGRADE(sv, SVt_PV);
4335 if (RsSNARF(PL_rs)) {
4339 else if (RsRECORD(PL_rs)) {
4340 I32 recsize, bytesread;
4343 /* Grab the size of the record we're getting */
4344 recsize = SvIV(SvRV(PL_rs));
4345 (void)SvPOK_only(sv); /* Validate pointer */
4346 buffer = SvGROW(sv, recsize + 1);
4349 /* VMS wants read instead of fread, because fread doesn't respect */
4350 /* RMS record boundaries. This is not necessarily a good thing to be */
4351 /* doing, but we've got no other real choice */
4352 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4354 bytesread = PerlIO_read(fp, buffer, recsize);
4356 SvCUR_set(sv, bytesread);
4357 buffer[bytesread] = '\0';
4358 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4360 else if (RsPARA(PL_rs)) {
4365 rsptr = SvPV(PL_rs, rslen);
4366 rslast = rslen ? rsptr[rslen - 1] : '\0';
4368 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4369 do { /* to make sure file boundaries work right */
4372 i = PerlIO_getc(fp);
4376 PerlIO_ungetc(fp,i);
4382 /* See if we know enough about I/O mechanism to cheat it ! */
4384 /* This used to be #ifdef test - it is made run-time test for ease
4385 of abstracting out stdio interface. One call should be cheap
4386 enough here - and may even be a macro allowing compile
4390 if (PerlIO_fast_gets(fp)) {
4393 * We're going to steal some values from the stdio struct
4394 * and put EVERYTHING in the innermost loop into registers.
4396 register STDCHAR *ptr;
4400 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4401 /* An ungetc()d char is handled separately from the regular
4402 * buffer, so we getc() it back out and stuff it in the buffer.
4404 i = PerlIO_getc(fp);
4405 if (i == EOF) return 0;
4406 *(--((*fp)->_ptr)) = (unsigned char) i;
4410 /* Here is some breathtakingly efficient cheating */
4412 cnt = PerlIO_get_cnt(fp); /* get count into register */
4413 (void)SvPOK_only(sv); /* validate pointer */
4414 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4415 if (cnt > 80 && SvLEN(sv) > append) {
4416 shortbuffered = cnt - SvLEN(sv) + append + 1;
4417 cnt -= shortbuffered;
4421 /* remember that cnt can be negative */
4422 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4427 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4428 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4429 DEBUG_P(PerlIO_printf(Perl_debug_log,
4430 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4431 DEBUG_P(PerlIO_printf(Perl_debug_log,
4432 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4433 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4434 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4439 while (cnt > 0) { /* this | eat */
4441 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4442 goto thats_all_folks; /* screams | sed :-) */
4446 Copy(ptr, bp, cnt, char); /* this | eat */
4447 bp += cnt; /* screams | dust */
4448 ptr += cnt; /* louder | sed :-) */
4453 if (shortbuffered) { /* oh well, must extend */
4454 cnt = shortbuffered;
4456 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4458 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4459 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4463 DEBUG_P(PerlIO_printf(Perl_debug_log,
4464 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4465 PTR2UV(ptr),(long)cnt));
4466 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4467 DEBUG_P(PerlIO_printf(Perl_debug_log,
4468 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4469 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4470 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4471 /* This used to call 'filbuf' in stdio form, but as that behaves like
4472 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4473 another abstraction. */
4474 i = PerlIO_getc(fp); /* get more characters */
4475 DEBUG_P(PerlIO_printf(Perl_debug_log,
4476 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4477 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4478 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4479 cnt = PerlIO_get_cnt(fp);
4480 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4481 DEBUG_P(PerlIO_printf(Perl_debug_log,
4482 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4484 if (i == EOF) /* all done for ever? */
4485 goto thats_really_all_folks;
4487 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4489 SvGROW(sv, bpx + cnt + 2);
4490 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4492 *bp++ = i; /* store character from PerlIO_getc */
4494 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4495 goto thats_all_folks;
4499 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4500 memNE((char*)bp - rslen, rsptr, rslen))
4501 goto screamer; /* go back to the fray */
4502 thats_really_all_folks:
4504 cnt += shortbuffered;
4505 DEBUG_P(PerlIO_printf(Perl_debug_log,
4506 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4507 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4508 DEBUG_P(PerlIO_printf(Perl_debug_log,
4509 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4510 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4511 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4513 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4514 DEBUG_P(PerlIO_printf(Perl_debug_log,
4515 "Screamer: done, len=%ld, string=|%.*s|\n",
4516 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4521 /*The big, slow, and stupid way */
4524 /* Need to work around EPOC SDK features */
4525 /* On WINS: MS VC5 generates calls to _chkstk, */
4526 /* if a `large' stack frame is allocated */
4527 /* gcc on MARM does not generate calls like these */
4533 register STDCHAR *bpe = buf + sizeof(buf);
4535 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4536 ; /* keep reading */
4540 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4541 /* Accomodate broken VAXC compiler, which applies U8 cast to
4542 * both args of ?: operator, causing EOF to change into 255
4544 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4548 sv_catpvn(sv, (char *) buf, cnt);
4550 sv_setpvn(sv, (char *) buf, cnt);
4552 if (i != EOF && /* joy */
4554 SvCUR(sv) < rslen ||
4555 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4559 * If we're reading from a TTY and we get a short read,
4560 * indicating that the user hit his EOF character, we need
4561 * to notice it now, because if we try to read from the TTY
4562 * again, the EOF condition will disappear.
4564 * The comparison of cnt to sizeof(buf) is an optimization
4565 * that prevents unnecessary calls to feof().
4569 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4574 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4575 while (i != EOF) { /* to make sure file boundaries work right */
4576 i = PerlIO_getc(fp);
4578 PerlIO_ungetc(fp,i);
4584 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4591 Auto-increment of the value in the SV.
4597 Perl_sv_inc(pTHX_ register SV *sv)
4606 if (SvTHINKFIRST(sv)) {
4607 if (SvREADONLY(sv)) {
4609 if (PL_curcop != &PL_compiling)
4610 Perl_croak(aTHX_ PL_no_modify);
4614 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4616 i = PTR2IV(SvRV(sv));
4621 flags = SvFLAGS(sv);
4622 if (flags & SVp_NOK) {
4623 (void)SvNOK_only(sv);
4627 if (flags & SVp_IOK) {
4629 if (SvUVX(sv) == UV_MAX)
4630 sv_setnv(sv, (NV)UV_MAX + 1.0);
4632 (void)SvIOK_only_UV(sv);
4635 if (SvIVX(sv) == IV_MAX)
4636 sv_setnv(sv, (NV)IV_MAX + 1.0);
4638 (void)SvIOK_only(sv);
4644 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4645 if ((flags & SVTYPEMASK) < SVt_PVNV)
4646 sv_upgrade(sv, SVt_NV);
4648 (void)SvNOK_only(sv);
4652 while (isALPHA(*d)) d++;
4653 while (isDIGIT(*d)) d++;
4655 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4659 while (d >= SvPVX(sv)) {
4667 /* MKS: The original code here died if letters weren't consecutive.
4668 * at least it didn't have to worry about non-C locales. The
4669 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4670 * arranged in order (although not consecutively) and that only
4671 * [A-Za-z] are accepted by isALPHA in the C locale.
4673 if (*d != 'z' && *d != 'Z') {
4674 do { ++*d; } while (!isALPHA(*d));
4677 *(d--) -= 'z' - 'a';
4682 *(d--) -= 'z' - 'a' + 1;
4686 /* oh,oh, the number grew */
4687 SvGROW(sv, SvCUR(sv) + 2);
4689 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4700 Auto-decrement of the value in the SV.
4706 Perl_sv_dec(pTHX_ register SV *sv)
4714 if (SvTHINKFIRST(sv)) {
4715 if (SvREADONLY(sv)) {
4717 if (PL_curcop != &PL_compiling)
4718 Perl_croak(aTHX_ PL_no_modify);
4722 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4724 i = PTR2IV(SvRV(sv));
4729 flags = SvFLAGS(sv);
4730 if (flags & SVp_NOK) {
4732 (void)SvNOK_only(sv);
4735 if (flags & SVp_IOK) {
4737 if (SvUVX(sv) == 0) {
4738 (void)SvIOK_only(sv);
4742 (void)SvIOK_only_UV(sv);
4746 if (SvIVX(sv) == IV_MIN)
4747 sv_setnv(sv, (NV)IV_MIN - 1.0);
4749 (void)SvIOK_only(sv);
4755 if (!(flags & SVp_POK)) {
4756 if ((flags & SVTYPEMASK) < SVt_PVNV)
4757 sv_upgrade(sv, SVt_NV);
4759 (void)SvNOK_only(sv);
4762 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4766 =for apidoc sv_mortalcopy
4768 Creates a new SV which is a copy of the original SV. The new SV is marked
4774 /* Make a string that will exist for the duration of the expression
4775 * evaluation. Actually, it may have to last longer than that, but
4776 * hopefully we won't free it until it has been assigned to a
4777 * permanent location. */
4780 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4786 sv_setsv(sv,oldstr);
4788 PL_tmps_stack[++PL_tmps_ix] = sv;
4794 =for apidoc sv_newmortal
4796 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4802 Perl_sv_newmortal(pTHX)
4808 SvFLAGS(sv) = SVs_TEMP;
4810 PL_tmps_stack[++PL_tmps_ix] = sv;
4815 =for apidoc sv_2mortal
4817 Marks an SV as mortal. The SV will be destroyed when the current context
4823 /* same thing without the copying */
4826 Perl_sv_2mortal(pTHX_ register SV *sv)
4831 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4834 PL_tmps_stack[++PL_tmps_ix] = sv;
4842 Creates a new SV and copies a string into it. The reference count for the
4843 SV is set to 1. If C<len> is zero, Perl will compute the length using
4844 strlen(). For efficiency, consider using C<newSVpvn> instead.
4850 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4857 sv_setpvn(sv,s,len);
4862 =for apidoc newSVpvn
4864 Creates a new SV and copies a string into it. The reference count for the
4865 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4866 string. You are responsible for ensuring that the source string is at least
4873 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4878 sv_setpvn(sv,s,len);
4882 #if defined(PERL_IMPLICIT_CONTEXT)
4884 Perl_newSVpvf_nocontext(const char* pat, ...)
4889 va_start(args, pat);
4890 sv = vnewSVpvf(pat, &args);
4897 =for apidoc newSVpvf
4899 Creates a new SV an initialize it with the string formatted like
4906 Perl_newSVpvf(pTHX_ const char* pat, ...)
4910 va_start(args, pat);
4911 sv = vnewSVpvf(pat, &args);
4917 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4921 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4928 Creates a new SV and copies a floating point value into it.
4929 The reference count for the SV is set to 1.
4935 Perl_newSVnv(pTHX_ NV n)
4947 Creates a new SV and copies an integer into it. The reference count for the
4954 Perl_newSViv(pTHX_ IV i)
4966 Creates a new SV and copies an unsigned integer into it.
4967 The reference count for the SV is set to 1.
4973 Perl_newSVuv(pTHX_ UV u)
4983 =for apidoc newRV_noinc
4985 Creates an RV wrapper for an SV. The reference count for the original
4986 SV is B<not> incremented.
4992 Perl_newRV_noinc(pTHX_ SV *tmpRef)
4998 sv_upgrade(sv, SVt_RV);
5005 /* newRV_inc is #defined to newRV in sv.h */
5007 Perl_newRV(pTHX_ SV *tmpRef)
5009 return newRV_noinc(SvREFCNT_inc(tmpRef));
5015 Creates a new SV which is an exact duplicate of the original SV.
5020 /* make an exact duplicate of old */
5023 Perl_newSVsv(pTHX_ register SV *old)
5030 if (SvTYPE(old) == SVTYPEMASK) {
5031 if (ckWARN_d(WARN_INTERNAL))
5032 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5047 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5055 char todo[PERL_UCHAR_MAX+1];
5060 if (!*s) { /* reset ?? searches */
5061 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5062 pm->op_pmdynflags &= ~PMdf_USED;
5067 /* reset variables */
5069 if (!HvARRAY(stash))
5072 Zero(todo, 256, char);
5074 i = (unsigned char)*s;
5078 max = (unsigned char)*s++;
5079 for ( ; i <= max; i++) {
5082 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5083 for (entry = HvARRAY(stash)[i];
5085 entry = HeNEXT(entry))
5087 if (!todo[(U8)*HeKEY(entry)])
5089 gv = (GV*)HeVAL(entry);
5091 if (SvTHINKFIRST(sv)) {
5092 if (!SvREADONLY(sv) && SvROK(sv))
5097 if (SvTYPE(sv) >= SVt_PV) {
5099 if (SvPVX(sv) != Nullch)
5106 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5108 #ifndef VMS /* VMS has no environ array */
5110 environ[0] = Nullch;
5119 Perl_sv_2io(pTHX_ SV *sv)
5125 switch (SvTYPE(sv)) {
5133 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5137 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5139 return sv_2io(SvRV(sv));
5140 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5146 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5153 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5160 return *gvp = Nullgv, Nullcv;
5161 switch (SvTYPE(sv)) {
5181 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5182 tryAMAGICunDEREF(to_cv);
5185 if (SvTYPE(sv) == SVt_PVCV) {
5194 Perl_croak(aTHX_ "Not a subroutine reference");
5199 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5205 if (lref && !GvCVu(gv)) {
5208 tmpsv = NEWSV(704,0);
5209 gv_efullname3(tmpsv, gv, Nullch);
5210 /* XXX this is probably not what they think they're getting.
5211 * It has the same effect as "sub name;", i.e. just a forward
5213 newSUB(start_subparse(FALSE, 0),
5214 newSVOP(OP_CONST, 0, tmpsv),
5219 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5228 Returns true if the SV has a true value by Perl's rules.
5234 Perl_sv_true(pTHX_ register SV *sv)
5241 if ((tXpv = (XPV*)SvANY(sv)) &&
5242 (tXpv->xpv_cur > 1 ||
5243 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5250 return SvIVX(sv) != 0;
5253 return SvNVX(sv) != 0.0;
5255 return sv_2bool(sv);
5261 Perl_sv_iv(pTHX_ register SV *sv)
5265 return (IV)SvUVX(sv);
5272 Perl_sv_uv(pTHX_ register SV *sv)
5277 return (UV)SvIVX(sv);
5283 Perl_sv_nv(pTHX_ register SV *sv)
5291 Perl_sv_pv(pTHX_ SV *sv)
5298 return sv_2pv(sv, &n_a);
5302 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5308 return sv_2pv(sv, lp);
5312 =for apidoc sv_pvn_force
5314 Get a sensible string out of the SV somehow.
5320 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5324 if (SvTHINKFIRST(sv) && !SvROK(sv))
5325 sv_force_normal(sv);
5331 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5333 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5334 PL_op_name[PL_op->op_type]);
5338 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5343 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5344 SvGROW(sv, len + 1);
5345 Move(s,SvPVX(sv),len,char);
5350 SvPOK_on(sv); /* validate pointer */
5352 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5353 PTR2UV(sv),SvPVX(sv)));
5360 Perl_sv_pvbyte(pTHX_ SV *sv)
5366 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5368 return sv_pvn(sv,lp);
5372 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5374 return sv_pvn_force(sv,lp);
5378 Perl_sv_pvutf8(pTHX_ SV *sv)
5380 sv_utf8_upgrade(sv);
5385 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5387 sv_utf8_upgrade(sv);
5388 return sv_pvn(sv,lp);
5392 =for apidoc sv_pvutf8n_force
5394 Get a sensible UTF8-encoded string out of the SV somehow. See
5401 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5403 sv_utf8_upgrade(sv);
5404 return sv_pvn_force(sv,lp);
5408 =for apidoc sv_reftype
5410 Returns a string describing what the SV is a reference to.
5416 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5418 if (ob && SvOBJECT(sv))
5419 return HvNAME(SvSTASH(sv));
5421 switch (SvTYPE(sv)) {
5435 case SVt_PVLV: return "LVALUE";
5436 case SVt_PVAV: return "ARRAY";
5437 case SVt_PVHV: return "HASH";
5438 case SVt_PVCV: return "CODE";
5439 case SVt_PVGV: return "GLOB";
5440 case SVt_PVFM: return "FORMAT";
5441 case SVt_PVIO: return "IO";
5442 default: return "UNKNOWN";
5448 =for apidoc sv_isobject
5450 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5451 object. If the SV is not an RV, or if the object is not blessed, then this
5458 Perl_sv_isobject(pTHX_ SV *sv)
5475 Returns a boolean indicating whether the SV is blessed into the specified
5476 class. This does not check for subtypes; use C<sv_derived_from> to verify
5477 an inheritance relationship.
5483 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5495 return strEQ(HvNAME(SvSTASH(sv)), name);
5501 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5502 it will be upgraded to one. If C<classname> is non-null then the new SV will
5503 be blessed in the specified package. The new SV is returned and its
5504 reference count is 1.
5510 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5517 SV_CHECK_THINKFIRST(rv);
5520 if (SvTYPE(rv) < SVt_RV)
5521 sv_upgrade(rv, SVt_RV);
5528 HV* stash = gv_stashpv(classname, TRUE);
5529 (void)sv_bless(rv, stash);
5535 =for apidoc sv_setref_pv
5537 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5538 argument will be upgraded to an RV. That RV will be modified to point to
5539 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5540 into the SV. The C<classname> argument indicates the package for the
5541 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5542 will be returned and will have a reference count of 1.
5544 Do not use with other Perl types such as HV, AV, SV, CV, because those
5545 objects will become corrupted by the pointer copy process.
5547 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5553 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5556 sv_setsv(rv, &PL_sv_undef);
5560 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5565 =for apidoc sv_setref_iv
5567 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5568 argument will be upgraded to an RV. That RV will be modified to point to
5569 the new SV. The C<classname> argument indicates the package for the
5570 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5571 will be returned and will have a reference count of 1.
5577 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5579 sv_setiv(newSVrv(rv,classname), iv);
5584 =for apidoc sv_setref_nv
5586 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5587 argument will be upgraded to an RV. That RV will be modified to point to
5588 the new SV. The C<classname> argument indicates the package for the
5589 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5590 will be returned and will have a reference count of 1.
5596 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5598 sv_setnv(newSVrv(rv,classname), nv);
5603 =for apidoc sv_setref_pvn
5605 Copies a string into a new SV, optionally blessing the SV. The length of the
5606 string must be specified with C<n>. The C<rv> argument will be upgraded to
5607 an RV. That RV will be modified to point to the new SV. The C<classname>
5608 argument indicates the package for the blessing. Set C<classname> to
5609 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5610 a reference count of 1.
5612 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5618 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5620 sv_setpvn(newSVrv(rv,classname), pv, n);
5625 =for apidoc sv_bless
5627 Blesses an SV into a specified package. The SV must be an RV. The package
5628 must be designated by its stash (see C<gv_stashpv()>). The reference count
5629 of the SV is unaffected.
5635 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5640 Perl_croak(aTHX_ "Can't bless non-reference value");
5642 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5643 if (SvREADONLY(tmpRef))
5644 Perl_croak(aTHX_ PL_no_modify);
5645 if (SvOBJECT(tmpRef)) {
5646 if (SvTYPE(tmpRef) != SVt_PVIO)
5648 SvREFCNT_dec(SvSTASH(tmpRef));
5651 SvOBJECT_on(tmpRef);
5652 if (SvTYPE(tmpRef) != SVt_PVIO)
5654 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5655 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5666 S_sv_unglob(pTHX_ SV *sv)
5670 assert(SvTYPE(sv) == SVt_PVGV);
5675 SvREFCNT_dec(GvSTASH(sv));
5676 GvSTASH(sv) = Nullhv;
5678 sv_unmagic(sv, '*');
5679 Safefree(GvNAME(sv));
5682 /* need to keep SvANY(sv) in the right arena */
5683 xpvmg = new_XPVMG();
5684 StructCopy(SvANY(sv), xpvmg, XPVMG);
5685 del_XPVGV(SvANY(sv));
5688 SvFLAGS(sv) &= ~SVTYPEMASK;
5689 SvFLAGS(sv) |= SVt_PVMG;
5693 =for apidoc sv_unref
5695 Unsets the RV status of the SV, and decrements the reference count of
5696 whatever was being referenced by the RV. This can almost be thought of
5697 as a reversal of C<newSVrv>. See C<SvROK_off>.
5703 Perl_sv_unref(pTHX_ SV *sv)
5707 if (SvWEAKREF(sv)) {
5715 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5718 sv_2mortal(rv); /* Schedule for freeing later */
5722 Perl_sv_taint(pTHX_ SV *sv)
5724 sv_magic((sv), Nullsv, 't', Nullch, 0);
5728 Perl_sv_untaint(pTHX_ SV *sv)
5730 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5731 MAGIC *mg = mg_find(sv, 't');
5738 Perl_sv_tainted(pTHX_ SV *sv)
5740 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5741 MAGIC *mg = mg_find(sv, 't');
5742 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5749 =for apidoc sv_setpviv
5751 Copies an integer into the given SV, also updating its string value.
5752 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5758 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5760 char buf[TYPE_CHARS(UV)];
5762 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5764 sv_setpvn(sv, ptr, ebuf - ptr);
5769 =for apidoc sv_setpviv_mg
5771 Like C<sv_setpviv>, but also handles 'set' magic.
5777 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5779 char buf[TYPE_CHARS(UV)];
5781 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5783 sv_setpvn(sv, ptr, ebuf - ptr);
5787 #if defined(PERL_IMPLICIT_CONTEXT)
5789 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5793 va_start(args, pat);
5794 sv_vsetpvf(sv, pat, &args);
5800 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5804 va_start(args, pat);
5805 sv_vsetpvf_mg(sv, pat, &args);
5811 =for apidoc sv_setpvf
5813 Processes its arguments like C<sprintf> and sets an SV to the formatted
5814 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5820 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5823 va_start(args, pat);
5824 sv_vsetpvf(sv, pat, &args);
5829 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5831 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5835 =for apidoc sv_setpvf_mg
5837 Like C<sv_setpvf>, but also handles 'set' magic.
5843 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5846 va_start(args, pat);
5847 sv_vsetpvf_mg(sv, pat, &args);
5852 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5854 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5858 #if defined(PERL_IMPLICIT_CONTEXT)
5860 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5864 va_start(args, pat);
5865 sv_vcatpvf(sv, pat, &args);
5870 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5874 va_start(args, pat);
5875 sv_vcatpvf_mg(sv, pat, &args);
5881 =for apidoc sv_catpvf
5883 Processes its arguments like C<sprintf> and appends the formatted output
5884 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5885 typically be called after calling this function to handle 'set' magic.
5891 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5894 va_start(args, pat);
5895 sv_vcatpvf(sv, pat, &args);
5900 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5902 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5906 =for apidoc sv_catpvf_mg
5908 Like C<sv_catpvf>, but also handles 'set' magic.
5914 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5917 va_start(args, pat);
5918 sv_vcatpvf_mg(sv, pat, &args);
5923 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5925 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5930 =for apidoc sv_vsetpvfn
5932 Works like C<vcatpvfn> but copies the text into the SV instead of
5939 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5941 sv_setpvn(sv, "", 0);
5942 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5946 =for apidoc sv_vcatpvfn
5948 Processes its arguments like C<vsprintf> and appends the formatted output
5949 to an SV. Uses an array of SVs if the C style variable argument list is
5950 missing (NULL). When running with taint checks enabled, indicates via
5951 C<maybe_tainted> if results are untrustworthy (often due to the use of
5958 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5966 static char nullstr[] = "(null)";
5969 /* no matter what, this is a string now */
5970 (void)SvPV_force(sv, origlen);
5972 /* special-case "", "%s", and "%_" */
5975 if (patlen == 2 && pat[0] == '%') {
5979 char *s = va_arg(*args, char*);
5980 sv_catpv(sv, s ? s : nullstr);
5982 else if (svix < svmax) {
5983 sv_catsv(sv, *svargs);
5984 if (DO_UTF8(*svargs))
5990 argsv = va_arg(*args, SV*);
5991 sv_catsv(sv, argsv);
5996 /* See comment on '_' below */
6001 patend = (char*)pat + patlen;
6002 for (p = (char*)pat; p < patend; p = q) {
6005 bool vectorize = FALSE;
6012 bool has_precis = FALSE;
6014 bool is_utf = FALSE;
6017 U8 utf8buf[UTF8_MAXLEN];
6018 STRLEN esignlen = 0;
6020 char *eptr = Nullch;
6022 /* Times 4: a decimal digit takes more than 3 binary digits.
6023 * NV_DIG: mantissa takes than many decimal digits.
6024 * Plus 32: Playing safe. */
6025 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6026 /* large enough for "%#.#f" --chip */
6027 /* what about long double NVs? --jhi */
6030 U8 *vecstr = Null(U8*);
6042 STRLEN dotstrlen = 1;
6044 for (q = p; q < patend && *q != '%'; ++q) ;
6046 sv_catpvn(sv, p, q - p);
6075 case '*': /* printf("%*vX",":",$ipv6addr) */
6080 vecsv = va_arg(*args, SV*);
6081 else if (svix < svmax)
6082 vecsv = svargs[svix++];
6085 dotstr = SvPVx(vecsv,dotstrlen);
6104 case '1': case '2': case '3':
6105 case '4': case '5': case '6':
6106 case '7': case '8': case '9':
6109 width = width * 10 + (*q++ - '0');
6114 i = va_arg(*args, int);
6116 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6118 width = (i < 0) ? -i : i;
6129 i = va_arg(*args, int);
6131 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6132 precis = (i < 0) ? 0 : i;
6138 precis = precis * 10 + (*q++ - '0');
6145 vecsv = va_arg(*args, SV*);
6146 vecstr = (U8*)SvPVx(vecsv,veclen);
6147 utf = DO_UTF8(vecsv);
6149 else if (svix < svmax) {
6150 vecsv = svargs[svix++];
6151 vecstr = (U8*)SvPVx(vecsv,veclen);
6152 utf = DO_UTF8(vecsv);
6172 if (*(q + 1) == 'l') { /* lld */
6199 uv = va_arg(*args, int);
6201 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6202 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6203 eptr = (char*)utf8buf;
6204 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6216 eptr = va_arg(*args, char*);
6218 #ifdef MACOS_TRADITIONAL
6219 /* On MacOS, %#s format is used for Pascal strings */
6224 elen = strlen(eptr);
6227 elen = sizeof nullstr - 1;
6230 else if (svix < svmax) {
6231 argsv = svargs[svix++];
6232 eptr = SvPVx(argsv, elen);
6233 if (DO_UTF8(argsv)) {
6234 if (has_precis && precis < elen) {
6236 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6239 if (width) { /* fudge width (can't fudge elen) */
6240 width += elen - sv_len_utf8(argsv);
6249 * The "%_" hack might have to be changed someday,
6250 * if ISO or ANSI decide to use '_' for something.
6251 * So we keep it hidden from users' code.
6255 argsv = va_arg(*args,SV*);
6256 eptr = SvPVx(argsv, elen);
6262 if (has_precis && elen > precis)
6272 uv = PTR2UV(va_arg(*args, void*));
6274 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6294 iv = (IV)utf8_to_uv(vecstr, &ulen);
6304 case 'h': iv = (short)va_arg(*args, int); break;
6305 default: iv = va_arg(*args, int); break;
6306 case 'l': iv = va_arg(*args, long); break;
6307 case 'V': iv = va_arg(*args, IV); break;
6309 case 'q': iv = va_arg(*args, Quad_t); break;
6314 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6316 case 'h': iv = (short)iv; break;
6318 case 'l': iv = (long)iv; break;
6321 case 'q': iv = (Quad_t)iv; break;
6328 esignbuf[esignlen++] = plus;
6332 esignbuf[esignlen++] = '-';
6376 uv = utf8_to_uv(vecstr, &ulen);
6386 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6387 default: uv = va_arg(*args, unsigned); break;
6388 case 'l': uv = va_arg(*args, unsigned long); break;
6389 case 'V': uv = va_arg(*args, UV); break;
6391 case 'q': uv = va_arg(*args, Quad_t); break;
6396 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6398 case 'h': uv = (unsigned short)uv; break;
6400 case 'l': uv = (unsigned long)uv; break;
6403 case 'q': uv = (Quad_t)uv; break;
6409 eptr = ebuf + sizeof ebuf;
6415 p = (char*)((c == 'X')
6416 ? "0123456789ABCDEF" : "0123456789abcdef");
6422 esignbuf[esignlen++] = '0';
6423 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6429 *--eptr = '0' + dig;
6431 if (alt && *eptr != '0')
6437 *--eptr = '0' + dig;
6440 esignbuf[esignlen++] = '0';
6441 esignbuf[esignlen++] = 'b';
6444 default: /* it had better be ten or less */
6445 #if defined(PERL_Y2KWARN)
6446 if (ckWARN(WARN_Y2K)) {
6448 char *s = SvPV(sv,n);
6449 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6450 && (n == 2 || !isDIGIT(s[n-3])))
6452 Perl_warner(aTHX_ WARN_Y2K,
6453 "Possible Y2K bug: %%%c %s",
6454 c, "format string following '19'");
6460 *--eptr = '0' + dig;
6461 } while (uv /= base);
6464 elen = (ebuf + sizeof ebuf) - eptr;
6467 zeros = precis - elen;
6468 else if (precis == 0 && elen == 1 && *eptr == '0')
6473 /* FLOATING POINT */
6476 c = 'f'; /* maybe %F isn't supported here */
6482 /* This is evil, but floating point is even more evil */
6486 nv = va_arg(*args, NV);
6488 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6491 if (c != 'e' && c != 'E') {
6493 (void)Perl_frexp(nv, &i);
6494 if (i == PERL_INT_MIN)
6495 Perl_die(aTHX_ "panic: frexp");
6497 need = BIT_DIGITS(i);
6499 need += has_precis ? precis : 6; /* known default */
6503 need += 20; /* fudge factor */
6504 if (PL_efloatsize < need) {
6505 Safefree(PL_efloatbuf);
6506 PL_efloatsize = need + 20; /* more fudge */
6507 New(906, PL_efloatbuf, PL_efloatsize, char);
6508 PL_efloatbuf[0] = '\0';
6511 eptr = ebuf + sizeof ebuf;
6514 #ifdef USE_LONG_DOUBLE
6516 static char const my_prifldbl[] = PERL_PRIfldbl;
6517 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6518 while (p >= my_prifldbl) { *--eptr = *p--; }
6523 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6528 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6541 RESTORE_NUMERIC_STANDARD();
6542 (void)sprintf(PL_efloatbuf, eptr, nv);
6543 RESTORE_NUMERIC_LOCAL();
6546 eptr = PL_efloatbuf;
6547 elen = strlen(PL_efloatbuf);
6554 i = SvCUR(sv) - origlen;
6557 case 'h': *(va_arg(*args, short*)) = i; break;
6558 default: *(va_arg(*args, int*)) = i; break;
6559 case 'l': *(va_arg(*args, long*)) = i; break;
6560 case 'V': *(va_arg(*args, IV*)) = i; break;
6562 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6566 else if (svix < svmax)
6567 sv_setuv_mg(svargs[svix++], (UV)i);
6568 continue; /* not "break" */
6575 if (!args && ckWARN(WARN_PRINTF) &&
6576 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6577 SV *msg = sv_newmortal();
6578 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6579 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6582 Perl_sv_catpvf(aTHX_ msg,
6583 "\"%%%c\"", c & 0xFF);
6585 Perl_sv_catpvf(aTHX_ msg,
6586 "\"%%\\%03"UVof"\"",
6589 sv_catpv(msg, "end of string");
6590 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6593 /* output mangled stuff ... */
6599 /* ... right here, because formatting flags should not apply */
6600 SvGROW(sv, SvCUR(sv) + elen + 1);
6602 memcpy(p, eptr, elen);
6605 SvCUR(sv) = p - SvPVX(sv);
6606 continue; /* not "break" */
6609 have = esignlen + zeros + elen;
6610 need = (have > width ? have : width);
6613 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6615 if (esignlen && fill == '0') {
6616 for (i = 0; i < esignlen; i++)
6620 memset(p, fill, gap);
6623 if (esignlen && fill != '0') {
6624 for (i = 0; i < esignlen; i++)
6628 for (i = zeros; i; i--)
6632 memcpy(p, eptr, elen);
6636 memset(p, ' ', gap);
6641 memcpy(p, dotstr, dotstrlen);
6645 vectorize = FALSE; /* done iterating over vecstr */
6650 SvCUR(sv) = p - SvPVX(sv);
6658 #if defined(USE_ITHREADS)
6660 #if defined(USE_THREADS)
6661 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6664 #ifndef GpREFCNT_inc
6665 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6669 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6670 #define av_dup(s) (AV*)sv_dup((SV*)s)
6671 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6672 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6673 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6674 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6675 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6676 #define io_dup(s) (IO*)sv_dup((SV*)s)
6677 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6678 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6679 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6680 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6681 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6684 Perl_re_dup(pTHX_ REGEXP *r)
6686 /* XXX fix when pmop->op_pmregexp becomes shared */
6687 return ReREFCNT_inc(r);
6691 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6695 return (PerlIO*)NULL;
6697 /* look for it in the table first */
6698 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6702 /* create anew and remember what it is */
6703 ret = PerlIO_fdupopen(fp);
6704 ptr_table_store(PL_ptr_table, fp, ret);
6709 Perl_dirp_dup(pTHX_ DIR *dp)
6718 Perl_gp_dup(pTHX_ GP *gp)
6723 /* look for it in the table first */
6724 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6728 /* create anew and remember what it is */
6729 Newz(0, ret, 1, GP);
6730 ptr_table_store(PL_ptr_table, gp, ret);
6733 ret->gp_refcnt = 0; /* must be before any other dups! */
6734 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6735 ret->gp_io = io_dup_inc(gp->gp_io);
6736 ret->gp_form = cv_dup_inc(gp->gp_form);
6737 ret->gp_av = av_dup_inc(gp->gp_av);
6738 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6739 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6740 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6741 ret->gp_cvgen = gp->gp_cvgen;
6742 ret->gp_flags = gp->gp_flags;
6743 ret->gp_line = gp->gp_line;
6744 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6749 Perl_mg_dup(pTHX_ MAGIC *mg)
6751 MAGIC *mgret = (MAGIC*)NULL;
6754 return (MAGIC*)NULL;
6755 /* look for it in the table first */
6756 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6760 for (; mg; mg = mg->mg_moremagic) {
6762 Newz(0, nmg, 1, MAGIC);
6766 mgprev->mg_moremagic = nmg;
6767 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6768 nmg->mg_private = mg->mg_private;
6769 nmg->mg_type = mg->mg_type;
6770 nmg->mg_flags = mg->mg_flags;
6771 if (mg->mg_type == 'r') {
6772 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6775 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6776 ? sv_dup_inc(mg->mg_obj)
6777 : sv_dup(mg->mg_obj);
6779 nmg->mg_len = mg->mg_len;
6780 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6781 if (mg->mg_ptr && mg->mg_type != 'g') {
6782 if (mg->mg_len >= 0) {
6783 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6784 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6785 AMT *amtp = (AMT*)mg->mg_ptr;
6786 AMT *namtp = (AMT*)nmg->mg_ptr;
6788 for (i = 1; i < NofAMmeth; i++) {
6789 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6793 else if (mg->mg_len == HEf_SVKEY)
6794 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6802 Perl_ptr_table_new(pTHX)
6805 Newz(0, tbl, 1, PTR_TBL_t);
6808 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6813 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6815 PTR_TBL_ENT_t *tblent;
6816 UV hash = PTR2UV(sv);
6818 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6819 for (; tblent; tblent = tblent->next) {
6820 if (tblent->oldval == sv)
6821 return tblent->newval;
6827 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6829 PTR_TBL_ENT_t *tblent, **otblent;
6830 /* XXX this may be pessimal on platforms where pointers aren't good
6831 * hash values e.g. if they grow faster in the most significant
6833 UV hash = PTR2UV(oldv);
6837 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6838 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6839 if (tblent->oldval == oldv) {
6840 tblent->newval = newv;
6845 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6846 tblent->oldval = oldv;
6847 tblent->newval = newv;
6848 tblent->next = *otblent;
6851 if (i && tbl->tbl_items > tbl->tbl_max)
6852 ptr_table_split(tbl);
6856 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6858 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6859 UV oldsize = tbl->tbl_max + 1;
6860 UV newsize = oldsize * 2;
6863 Renew(ary, newsize, PTR_TBL_ENT_t*);
6864 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6865 tbl->tbl_max = --newsize;
6867 for (i=0; i < oldsize; i++, ary++) {
6868 PTR_TBL_ENT_t **curentp, **entp, *ent;
6871 curentp = ary + oldsize;
6872 for (entp = ary, ent = *ary; ent; ent = *entp) {
6873 if ((newsize & PTR2UV(ent->oldval)) != i) {
6875 ent->next = *curentp;
6890 Perl_sv_dup(pTHX_ SV *sstr)
6894 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6896 /* look for it in the table first */
6897 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6901 /* create anew and remember what it is */
6903 ptr_table_store(PL_ptr_table, sstr, dstr);
6906 SvFLAGS(dstr) = SvFLAGS(sstr);
6907 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6908 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6911 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6912 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6913 PL_watch_pvx, SvPVX(sstr));
6916 switch (SvTYPE(sstr)) {
6921 SvANY(dstr) = new_XIV();
6922 SvIVX(dstr) = SvIVX(sstr);
6925 SvANY(dstr) = new_XNV();
6926 SvNVX(dstr) = SvNVX(sstr);
6929 SvANY(dstr) = new_XRV();
6930 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6933 SvANY(dstr) = new_XPV();
6934 SvCUR(dstr) = SvCUR(sstr);
6935 SvLEN(dstr) = SvLEN(sstr);
6937 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6938 else if (SvPVX(sstr) && SvLEN(sstr))
6939 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6941 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6944 SvANY(dstr) = new_XPVIV();
6945 SvCUR(dstr) = SvCUR(sstr);
6946 SvLEN(dstr) = SvLEN(sstr);
6947 SvIVX(dstr) = SvIVX(sstr);
6949 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6950 else if (SvPVX(sstr) && SvLEN(sstr))
6951 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6953 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6956 SvANY(dstr) = new_XPVNV();
6957 SvCUR(dstr) = SvCUR(sstr);
6958 SvLEN(dstr) = SvLEN(sstr);
6959 SvIVX(dstr) = SvIVX(sstr);
6960 SvNVX(dstr) = SvNVX(sstr);
6962 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6963 else if (SvPVX(sstr) && SvLEN(sstr))
6964 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6966 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6969 SvANY(dstr) = new_XPVMG();
6970 SvCUR(dstr) = SvCUR(sstr);
6971 SvLEN(dstr) = SvLEN(sstr);
6972 SvIVX(dstr) = SvIVX(sstr);
6973 SvNVX(dstr) = SvNVX(sstr);
6974 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6975 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6977 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6978 else if (SvPVX(sstr) && SvLEN(sstr))
6979 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6981 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6984 SvANY(dstr) = new_XPVBM();
6985 SvCUR(dstr) = SvCUR(sstr);
6986 SvLEN(dstr) = SvLEN(sstr);
6987 SvIVX(dstr) = SvIVX(sstr);
6988 SvNVX(dstr) = SvNVX(sstr);
6989 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6990 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6992 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6993 else if (SvPVX(sstr) && SvLEN(sstr))
6994 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6996 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6997 BmRARE(dstr) = BmRARE(sstr);
6998 BmUSEFUL(dstr) = BmUSEFUL(sstr);
6999 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7002 SvANY(dstr) = new_XPVLV();
7003 SvCUR(dstr) = SvCUR(sstr);
7004 SvLEN(dstr) = SvLEN(sstr);
7005 SvIVX(dstr) = SvIVX(sstr);
7006 SvNVX(dstr) = SvNVX(sstr);
7007 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7008 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7010 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7011 else if (SvPVX(sstr) && SvLEN(sstr))
7012 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7014 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7015 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7016 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7017 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7018 LvTYPE(dstr) = LvTYPE(sstr);
7021 SvANY(dstr) = new_XPVGV();
7022 SvCUR(dstr) = SvCUR(sstr);
7023 SvLEN(dstr) = SvLEN(sstr);
7024 SvIVX(dstr) = SvIVX(sstr);
7025 SvNVX(dstr) = SvNVX(sstr);
7026 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7027 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7029 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7030 else if (SvPVX(sstr) && SvLEN(sstr))
7031 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7033 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7034 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7035 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7036 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7037 GvFLAGS(dstr) = GvFLAGS(sstr);
7038 GvGP(dstr) = gp_dup(GvGP(sstr));
7039 (void)GpREFCNT_inc(GvGP(dstr));
7042 SvANY(dstr) = new_XPVIO();
7043 SvCUR(dstr) = SvCUR(sstr);
7044 SvLEN(dstr) = SvLEN(sstr);
7045 SvIVX(dstr) = SvIVX(sstr);
7046 SvNVX(dstr) = SvNVX(sstr);
7047 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7048 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7050 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7051 else if (SvPVX(sstr) && SvLEN(sstr))
7052 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7054 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7055 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7056 if (IoOFP(sstr) == IoIFP(sstr))
7057 IoOFP(dstr) = IoIFP(dstr);
7059 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7060 /* PL_rsfp_filters entries have fake IoDIRP() */
7061 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7062 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7064 IoDIRP(dstr) = IoDIRP(sstr);
7065 IoLINES(dstr) = IoLINES(sstr);
7066 IoPAGE(dstr) = IoPAGE(sstr);
7067 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7068 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7069 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7070 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7071 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7072 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7073 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7074 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7075 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7076 IoTYPE(dstr) = IoTYPE(sstr);
7077 IoFLAGS(dstr) = IoFLAGS(sstr);
7080 SvANY(dstr) = new_XPVAV();
7081 SvCUR(dstr) = SvCUR(sstr);
7082 SvLEN(dstr) = SvLEN(sstr);
7083 SvIVX(dstr) = SvIVX(sstr);
7084 SvNVX(dstr) = SvNVX(sstr);
7085 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7086 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7087 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7088 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7089 if (AvARRAY((AV*)sstr)) {
7090 SV **dst_ary, **src_ary;
7091 SSize_t items = AvFILLp((AV*)sstr) + 1;
7093 src_ary = AvARRAY((AV*)sstr);
7094 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7095 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7096 SvPVX(dstr) = (char*)dst_ary;
7097 AvALLOC((AV*)dstr) = dst_ary;
7098 if (AvREAL((AV*)sstr)) {
7100 *dst_ary++ = sv_dup_inc(*src_ary++);
7104 *dst_ary++ = sv_dup(*src_ary++);
7106 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7107 while (items-- > 0) {
7108 *dst_ary++ = &PL_sv_undef;
7112 SvPVX(dstr) = Nullch;
7113 AvALLOC((AV*)dstr) = (SV**)NULL;
7117 SvANY(dstr) = new_XPVHV();
7118 SvCUR(dstr) = SvCUR(sstr);
7119 SvLEN(dstr) = SvLEN(sstr);
7120 SvIVX(dstr) = SvIVX(sstr);
7121 SvNVX(dstr) = SvNVX(sstr);
7122 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7123 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7124 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7125 if (HvARRAY((HV*)sstr)) {
7127 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7128 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7129 Newz(0, dxhv->xhv_array,
7130 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7131 while (i <= sxhv->xhv_max) {
7132 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7133 !!HvSHAREKEYS(sstr));
7136 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7139 SvPVX(dstr) = Nullch;
7140 HvEITER((HV*)dstr) = (HE*)NULL;
7142 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7143 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7146 SvANY(dstr) = new_XPVFM();
7147 FmLINES(dstr) = FmLINES(sstr);
7151 SvANY(dstr) = new_XPVCV();
7153 SvCUR(dstr) = SvCUR(sstr);
7154 SvLEN(dstr) = SvLEN(sstr);
7155 SvIVX(dstr) = SvIVX(sstr);
7156 SvNVX(dstr) = SvNVX(sstr);
7157 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7158 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7159 if (SvPVX(sstr) && SvLEN(sstr))
7160 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7162 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7163 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7164 CvSTART(dstr) = CvSTART(sstr);
7165 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7166 CvXSUB(dstr) = CvXSUB(sstr);
7167 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7168 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7169 CvDEPTH(dstr) = CvDEPTH(sstr);
7170 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7171 /* XXX padlists are real, but pretend to be not */
7172 AvREAL_on(CvPADLIST(sstr));
7173 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7174 AvREAL_off(CvPADLIST(sstr));
7175 AvREAL_off(CvPADLIST(dstr));
7178 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7179 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7180 CvFLAGS(dstr) = CvFLAGS(sstr);
7183 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7187 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7194 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7199 return (PERL_CONTEXT*)NULL;
7201 /* look for it in the table first */
7202 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7206 /* create anew and remember what it is */
7207 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7208 ptr_table_store(PL_ptr_table, cxs, ncxs);
7211 PERL_CONTEXT *cx = &cxs[ix];
7212 PERL_CONTEXT *ncx = &ncxs[ix];
7213 ncx->cx_type = cx->cx_type;
7214 if (CxTYPE(cx) == CXt_SUBST) {
7215 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7218 ncx->blk_oldsp = cx->blk_oldsp;
7219 ncx->blk_oldcop = cx->blk_oldcop;
7220 ncx->blk_oldretsp = cx->blk_oldretsp;
7221 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7222 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7223 ncx->blk_oldpm = cx->blk_oldpm;
7224 ncx->blk_gimme = cx->blk_gimme;
7225 switch (CxTYPE(cx)) {
7227 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7228 ? cv_dup_inc(cx->blk_sub.cv)
7229 : cv_dup(cx->blk_sub.cv));
7230 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7231 ? av_dup_inc(cx->blk_sub.argarray)
7233 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7234 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7235 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7236 ncx->blk_sub.lval = cx->blk_sub.lval;
7239 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7240 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7241 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7242 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7243 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7246 ncx->blk_loop.label = cx->blk_loop.label;
7247 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7248 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7249 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7250 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7251 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7252 ? cx->blk_loop.iterdata
7253 : gv_dup((GV*)cx->blk_loop.iterdata));
7254 ncx->blk_loop.oldcurpad
7255 = (SV**)ptr_table_fetch(PL_ptr_table,
7256 cx->blk_loop.oldcurpad);
7257 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7258 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7259 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7260 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7261 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7264 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7265 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7266 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7267 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7280 Perl_si_dup(pTHX_ PERL_SI *si)
7285 return (PERL_SI*)NULL;
7287 /* look for it in the table first */
7288 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7292 /* create anew and remember what it is */
7293 Newz(56, nsi, 1, PERL_SI);
7294 ptr_table_store(PL_ptr_table, si, nsi);
7296 nsi->si_stack = av_dup_inc(si->si_stack);
7297 nsi->si_cxix = si->si_cxix;
7298 nsi->si_cxmax = si->si_cxmax;
7299 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7300 nsi->si_type = si->si_type;
7301 nsi->si_prev = si_dup(si->si_prev);
7302 nsi->si_next = si_dup(si->si_next);
7303 nsi->si_markoff = si->si_markoff;
7308 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7309 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7310 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7311 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7312 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7313 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7314 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7315 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7316 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7317 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7318 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7319 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7322 #define pv_dup_inc(p) SAVEPV(p)
7323 #define pv_dup(p) SAVEPV(p)
7324 #define svp_dup_inc(p,pp) any_dup(p,pp)
7327 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7334 /* look for it in the table first */
7335 ret = ptr_table_fetch(PL_ptr_table, v);
7339 /* see if it is part of the interpreter structure */
7340 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7341 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7349 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7351 ANY *ss = proto_perl->Tsavestack;
7352 I32 ix = proto_perl->Tsavestack_ix;
7353 I32 max = proto_perl->Tsavestack_max;
7366 void (*dptr) (void*);
7367 void (*dxptr) (pTHXo_ void*);
7370 Newz(54, nss, max, ANY);
7376 case SAVEt_ITEM: /* normal string */
7377 sv = (SV*)POPPTR(ss,ix);
7378 TOPPTR(nss,ix) = sv_dup_inc(sv);
7379 sv = (SV*)POPPTR(ss,ix);
7380 TOPPTR(nss,ix) = sv_dup_inc(sv);
7382 case SAVEt_SV: /* scalar reference */
7383 sv = (SV*)POPPTR(ss,ix);
7384 TOPPTR(nss,ix) = sv_dup_inc(sv);
7385 gv = (GV*)POPPTR(ss,ix);
7386 TOPPTR(nss,ix) = gv_dup_inc(gv);
7388 case SAVEt_GENERIC_PVREF: /* generic char* */
7389 c = (char*)POPPTR(ss,ix);
7390 TOPPTR(nss,ix) = pv_dup(c);
7391 ptr = POPPTR(ss,ix);
7392 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7394 case SAVEt_GENERIC_SVREF: /* generic sv */
7395 case SAVEt_SVREF: /* scalar reference */
7396 sv = (SV*)POPPTR(ss,ix);
7397 TOPPTR(nss,ix) = sv_dup_inc(sv);
7398 ptr = POPPTR(ss,ix);
7399 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7401 case SAVEt_AV: /* array reference */
7402 av = (AV*)POPPTR(ss,ix);
7403 TOPPTR(nss,ix) = av_dup_inc(av);
7404 gv = (GV*)POPPTR(ss,ix);
7405 TOPPTR(nss,ix) = gv_dup(gv);
7407 case SAVEt_HV: /* hash reference */
7408 hv = (HV*)POPPTR(ss,ix);
7409 TOPPTR(nss,ix) = hv_dup_inc(hv);
7410 gv = (GV*)POPPTR(ss,ix);
7411 TOPPTR(nss,ix) = gv_dup(gv);
7413 case SAVEt_INT: /* int reference */
7414 ptr = POPPTR(ss,ix);
7415 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7416 intval = (int)POPINT(ss,ix);
7417 TOPINT(nss,ix) = intval;
7419 case SAVEt_LONG: /* long reference */
7420 ptr = POPPTR(ss,ix);
7421 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7422 longval = (long)POPLONG(ss,ix);
7423 TOPLONG(nss,ix) = longval;
7425 case SAVEt_I32: /* I32 reference */
7426 case SAVEt_I16: /* I16 reference */
7427 case SAVEt_I8: /* I8 reference */
7428 ptr = POPPTR(ss,ix);
7429 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7433 case SAVEt_IV: /* IV reference */
7434 ptr = POPPTR(ss,ix);
7435 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7439 case SAVEt_SPTR: /* SV* reference */
7440 ptr = POPPTR(ss,ix);
7441 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7442 sv = (SV*)POPPTR(ss,ix);
7443 TOPPTR(nss,ix) = sv_dup(sv);
7445 case SAVEt_VPTR: /* random* reference */
7446 ptr = POPPTR(ss,ix);
7447 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7448 ptr = POPPTR(ss,ix);
7449 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7451 case SAVEt_PPTR: /* char* reference */
7452 ptr = POPPTR(ss,ix);
7453 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7454 c = (char*)POPPTR(ss,ix);
7455 TOPPTR(nss,ix) = pv_dup(c);
7457 case SAVEt_HPTR: /* HV* reference */
7458 ptr = POPPTR(ss,ix);
7459 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7460 hv = (HV*)POPPTR(ss,ix);
7461 TOPPTR(nss,ix) = hv_dup(hv);
7463 case SAVEt_APTR: /* AV* reference */
7464 ptr = POPPTR(ss,ix);
7465 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7466 av = (AV*)POPPTR(ss,ix);
7467 TOPPTR(nss,ix) = av_dup(av);
7470 gv = (GV*)POPPTR(ss,ix);
7471 TOPPTR(nss,ix) = gv_dup(gv);
7473 case SAVEt_GP: /* scalar reference */
7474 gp = (GP*)POPPTR(ss,ix);
7475 TOPPTR(nss,ix) = gp = gp_dup(gp);
7476 (void)GpREFCNT_inc(gp);
7477 gv = (GV*)POPPTR(ss,ix);
7478 TOPPTR(nss,ix) = gv_dup_inc(c);
7479 c = (char*)POPPTR(ss,ix);
7480 TOPPTR(nss,ix) = pv_dup(c);
7487 sv = (SV*)POPPTR(ss,ix);
7488 TOPPTR(nss,ix) = sv_dup_inc(sv);
7491 ptr = POPPTR(ss,ix);
7492 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7493 /* these are assumed to be refcounted properly */
7494 switch (((OP*)ptr)->op_type) {
7501 TOPPTR(nss,ix) = ptr;
7506 TOPPTR(nss,ix) = Nullop;
7511 TOPPTR(nss,ix) = Nullop;
7514 c = (char*)POPPTR(ss,ix);
7515 TOPPTR(nss,ix) = pv_dup_inc(c);
7518 longval = POPLONG(ss,ix);
7519 TOPLONG(nss,ix) = longval;
7522 hv = (HV*)POPPTR(ss,ix);
7523 TOPPTR(nss,ix) = hv_dup_inc(hv);
7524 c = (char*)POPPTR(ss,ix);
7525 TOPPTR(nss,ix) = pv_dup_inc(c);
7529 case SAVEt_DESTRUCTOR:
7530 ptr = POPPTR(ss,ix);
7531 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7532 dptr = POPDPTR(ss,ix);
7533 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7535 case SAVEt_DESTRUCTOR_X:
7536 ptr = POPPTR(ss,ix);
7537 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7538 dxptr = POPDXPTR(ss,ix);
7539 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7541 case SAVEt_REGCONTEXT:
7547 case SAVEt_STACK_POS: /* Position on Perl stack */
7551 case SAVEt_AELEM: /* array element */
7552 sv = (SV*)POPPTR(ss,ix);
7553 TOPPTR(nss,ix) = sv_dup_inc(sv);
7556 av = (AV*)POPPTR(ss,ix);
7557 TOPPTR(nss,ix) = av_dup_inc(av);
7559 case SAVEt_HELEM: /* hash element */
7560 sv = (SV*)POPPTR(ss,ix);
7561 TOPPTR(nss,ix) = sv_dup_inc(sv);
7562 sv = (SV*)POPPTR(ss,ix);
7563 TOPPTR(nss,ix) = sv_dup_inc(sv);
7564 hv = (HV*)POPPTR(ss,ix);
7565 TOPPTR(nss,ix) = hv_dup_inc(hv);
7568 ptr = POPPTR(ss,ix);
7569 TOPPTR(nss,ix) = ptr;
7576 av = (AV*)POPPTR(ss,ix);
7577 TOPPTR(nss,ix) = av_dup(av);
7580 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7592 perl_clone(PerlInterpreter *proto_perl, UV flags)
7595 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7598 #ifdef PERL_IMPLICIT_SYS
7599 return perl_clone_using(proto_perl, flags,
7601 proto_perl->IMemShared,
7602 proto_perl->IMemParse,
7612 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7613 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7614 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7615 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7616 struct IPerlDir* ipD, struct IPerlSock* ipS,
7617 struct IPerlProc* ipP)
7619 /* XXX many of the string copies here can be optimized if they're
7620 * constants; they need to be allocated as common memory and just
7621 * their pointers copied. */
7625 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7627 PERL_SET_THX(pPerl);
7628 # else /* !PERL_OBJECT */
7629 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7630 PERL_SET_THX(my_perl);
7633 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7638 # else /* !DEBUGGING */
7639 Zero(my_perl, 1, PerlInterpreter);
7640 # endif /* DEBUGGING */
7644 PL_MemShared = ipMS;
7652 # endif /* PERL_OBJECT */
7653 #else /* !PERL_IMPLICIT_SYS */
7655 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7656 PERL_SET_THX(my_perl);
7659 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7664 # else /* !DEBUGGING */
7665 Zero(my_perl, 1, PerlInterpreter);
7666 # endif /* DEBUGGING */
7667 #endif /* PERL_IMPLICIT_SYS */
7670 PL_xiv_arenaroot = NULL;
7672 PL_xnv_arenaroot = NULL;
7674 PL_xrv_arenaroot = NULL;
7676 PL_xpv_arenaroot = NULL;
7678 PL_xpviv_arenaroot = NULL;
7679 PL_xpviv_root = NULL;
7680 PL_xpvnv_arenaroot = NULL;
7681 PL_xpvnv_root = NULL;
7682 PL_xpvcv_arenaroot = NULL;
7683 PL_xpvcv_root = NULL;
7684 PL_xpvav_arenaroot = NULL;
7685 PL_xpvav_root = NULL;
7686 PL_xpvhv_arenaroot = NULL;
7687 PL_xpvhv_root = NULL;
7688 PL_xpvmg_arenaroot = NULL;
7689 PL_xpvmg_root = NULL;
7690 PL_xpvlv_arenaroot = NULL;
7691 PL_xpvlv_root = NULL;
7692 PL_xpvbm_arenaroot = NULL;
7693 PL_xpvbm_root = NULL;
7694 PL_he_arenaroot = NULL;
7696 PL_nice_chunk = NULL;
7697 PL_nice_chunk_size = 0;
7700 PL_sv_root = Nullsv;
7701 PL_sv_arenaroot = Nullsv;
7703 PL_debug = proto_perl->Idebug;
7705 /* create SV map for pointer relocation */
7706 PL_ptr_table = ptr_table_new();
7708 /* initialize these special pointers as early as possible */
7709 SvANY(&PL_sv_undef) = NULL;
7710 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7711 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7712 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7715 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7717 SvANY(&PL_sv_no) = new_XPVNV();
7719 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7720 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7721 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7722 SvCUR(&PL_sv_no) = 0;
7723 SvLEN(&PL_sv_no) = 1;
7724 SvNVX(&PL_sv_no) = 0;
7725 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7728 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7730 SvANY(&PL_sv_yes) = new_XPVNV();
7732 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7733 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7734 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7735 SvCUR(&PL_sv_yes) = 1;
7736 SvLEN(&PL_sv_yes) = 2;
7737 SvNVX(&PL_sv_yes) = 1;
7738 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7740 /* create shared string table */
7741 PL_strtab = newHV();
7742 HvSHAREKEYS_off(PL_strtab);
7743 hv_ksplit(PL_strtab, 512);
7744 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7746 PL_compiling = proto_perl->Icompiling;
7747 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7748 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7749 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7750 if (!specialWARN(PL_compiling.cop_warnings))
7751 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7752 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7754 /* pseudo environmental stuff */
7755 PL_origargc = proto_perl->Iorigargc;
7757 New(0, PL_origargv, i+1, char*);
7758 PL_origargv[i] = '\0';
7760 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7762 PL_envgv = gv_dup(proto_perl->Ienvgv);
7763 PL_incgv = gv_dup(proto_perl->Iincgv);
7764 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7765 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7766 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7767 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7770 PL_minus_c = proto_perl->Iminus_c;
7771 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7772 PL_localpatches = proto_perl->Ilocalpatches;
7773 PL_splitstr = proto_perl->Isplitstr;
7774 PL_preprocess = proto_perl->Ipreprocess;
7775 PL_minus_n = proto_perl->Iminus_n;
7776 PL_minus_p = proto_perl->Iminus_p;
7777 PL_minus_l = proto_perl->Iminus_l;
7778 PL_minus_a = proto_perl->Iminus_a;
7779 PL_minus_F = proto_perl->Iminus_F;
7780 PL_doswitches = proto_perl->Idoswitches;
7781 PL_dowarn = proto_perl->Idowarn;
7782 PL_doextract = proto_perl->Idoextract;
7783 PL_sawampersand = proto_perl->Isawampersand;
7784 PL_unsafe = proto_perl->Iunsafe;
7785 PL_inplace = SAVEPV(proto_perl->Iinplace);
7786 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7787 PL_perldb = proto_perl->Iperldb;
7788 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7790 /* magical thingies */
7791 /* XXX time(&PL_basetime) when asked for? */
7792 PL_basetime = proto_perl->Ibasetime;
7793 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7795 PL_maxsysfd = proto_perl->Imaxsysfd;
7796 PL_multiline = proto_perl->Imultiline;
7797 PL_statusvalue = proto_perl->Istatusvalue;
7799 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7802 /* shortcuts to various I/O objects */
7803 PL_stdingv = gv_dup(proto_perl->Istdingv);
7804 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7805 PL_defgv = gv_dup(proto_perl->Idefgv);
7806 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7807 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7808 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7810 /* shortcuts to regexp stuff */
7811 PL_replgv = gv_dup(proto_perl->Ireplgv);
7813 /* shortcuts to misc objects */
7814 PL_errgv = gv_dup(proto_perl->Ierrgv);
7816 /* shortcuts to debugging objects */
7817 PL_DBgv = gv_dup(proto_perl->IDBgv);
7818 PL_DBline = gv_dup(proto_perl->IDBline);
7819 PL_DBsub = gv_dup(proto_perl->IDBsub);
7820 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7821 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7822 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7823 PL_lineary = av_dup(proto_perl->Ilineary);
7824 PL_dbargs = av_dup(proto_perl->Idbargs);
7827 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7828 PL_curstash = hv_dup(proto_perl->Tcurstash);
7829 PL_debstash = hv_dup(proto_perl->Idebstash);
7830 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7831 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7833 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7834 PL_endav = av_dup_inc(proto_perl->Iendav);
7835 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7836 PL_initav = av_dup_inc(proto_perl->Iinitav);
7838 PL_sub_generation = proto_perl->Isub_generation;
7840 /* funky return mechanisms */
7841 PL_forkprocess = proto_perl->Iforkprocess;
7843 /* subprocess state */
7844 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7846 /* internal state */
7847 PL_tainting = proto_perl->Itainting;
7848 PL_maxo = proto_perl->Imaxo;
7849 if (proto_perl->Iop_mask)
7850 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7852 PL_op_mask = Nullch;
7854 /* current interpreter roots */
7855 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7856 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7857 PL_main_start = proto_perl->Imain_start;
7858 PL_eval_root = proto_perl->Ieval_root;
7859 PL_eval_start = proto_perl->Ieval_start;
7861 /* runtime control stuff */
7862 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7863 PL_copline = proto_perl->Icopline;
7865 PL_filemode = proto_perl->Ifilemode;
7866 PL_lastfd = proto_perl->Ilastfd;
7867 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7870 PL_gensym = proto_perl->Igensym;
7871 PL_preambled = proto_perl->Ipreambled;
7872 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7873 PL_laststatval = proto_perl->Ilaststatval;
7874 PL_laststype = proto_perl->Ilaststype;
7875 PL_mess_sv = Nullsv;
7877 PL_orslen = proto_perl->Iorslen;
7878 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7879 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7881 /* interpreter atexit processing */
7882 PL_exitlistlen = proto_perl->Iexitlistlen;
7883 if (PL_exitlistlen) {
7884 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7885 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7888 PL_exitlist = (PerlExitListEntry*)NULL;
7889 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7891 PL_profiledata = NULL;
7892 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7893 /* PL_rsfp_filters entries have fake IoDIRP() */
7894 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7896 PL_compcv = cv_dup(proto_perl->Icompcv);
7897 PL_comppad = av_dup(proto_perl->Icomppad);
7898 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7899 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7900 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7901 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7902 proto_perl->Tcurpad);
7904 #ifdef HAVE_INTERP_INTERN
7905 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7908 /* more statics moved here */
7909 PL_generation = proto_perl->Igeneration;
7910 PL_DBcv = cv_dup(proto_perl->IDBcv);
7912 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7913 PL_in_clean_all = proto_perl->Iin_clean_all;
7915 PL_uid = proto_perl->Iuid;
7916 PL_euid = proto_perl->Ieuid;
7917 PL_gid = proto_perl->Igid;
7918 PL_egid = proto_perl->Iegid;
7919 PL_nomemok = proto_perl->Inomemok;
7920 PL_an = proto_perl->Ian;
7921 PL_cop_seqmax = proto_perl->Icop_seqmax;
7922 PL_op_seqmax = proto_perl->Iop_seqmax;
7923 PL_evalseq = proto_perl->Ievalseq;
7924 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7925 PL_origalen = proto_perl->Iorigalen;
7926 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7927 PL_osname = SAVEPV(proto_perl->Iosname);
7928 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7929 PL_sighandlerp = proto_perl->Isighandlerp;
7932 PL_runops = proto_perl->Irunops;
7934 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7937 PL_cshlen = proto_perl->Icshlen;
7938 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7941 PL_lex_state = proto_perl->Ilex_state;
7942 PL_lex_defer = proto_perl->Ilex_defer;
7943 PL_lex_expect = proto_perl->Ilex_expect;
7944 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7945 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7946 PL_lex_starts = proto_perl->Ilex_starts;
7947 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7948 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7949 PL_lex_op = proto_perl->Ilex_op;
7950 PL_lex_inpat = proto_perl->Ilex_inpat;
7951 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7952 PL_lex_brackets = proto_perl->Ilex_brackets;
7953 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7954 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7955 PL_lex_casemods = proto_perl->Ilex_casemods;
7956 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7957 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7959 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7960 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7961 PL_nexttoke = proto_perl->Inexttoke;
7963 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7964 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7965 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7966 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7967 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7968 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7969 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7970 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7971 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7972 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7973 PL_pending_ident = proto_perl->Ipending_ident;
7974 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7976 PL_expect = proto_perl->Iexpect;
7978 PL_multi_start = proto_perl->Imulti_start;
7979 PL_multi_end = proto_perl->Imulti_end;
7980 PL_multi_open = proto_perl->Imulti_open;
7981 PL_multi_close = proto_perl->Imulti_close;
7983 PL_error_count = proto_perl->Ierror_count;
7984 PL_subline = proto_perl->Isubline;
7985 PL_subname = sv_dup_inc(proto_perl->Isubname);
7987 PL_min_intro_pending = proto_perl->Imin_intro_pending;
7988 PL_max_intro_pending = proto_perl->Imax_intro_pending;
7989 PL_padix = proto_perl->Ipadix;
7990 PL_padix_floor = proto_perl->Ipadix_floor;
7991 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
7993 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
7994 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7995 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
7996 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7997 PL_last_lop_op = proto_perl->Ilast_lop_op;
7998 PL_in_my = proto_perl->Iin_my;
7999 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8001 PL_cryptseen = proto_perl->Icryptseen;
8004 PL_hints = proto_perl->Ihints;
8006 PL_amagic_generation = proto_perl->Iamagic_generation;
8008 #ifdef USE_LOCALE_COLLATE
8009 PL_collation_ix = proto_perl->Icollation_ix;
8010 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8011 PL_collation_standard = proto_perl->Icollation_standard;
8012 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8013 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8014 #endif /* USE_LOCALE_COLLATE */
8016 #ifdef USE_LOCALE_NUMERIC
8017 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8018 PL_numeric_standard = proto_perl->Inumeric_standard;
8019 PL_numeric_local = proto_perl->Inumeric_local;
8020 PL_numeric_radix = proto_perl->Inumeric_radix;
8021 #endif /* !USE_LOCALE_NUMERIC */
8023 /* utf8 character classes */
8024 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8025 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8026 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8027 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8028 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8029 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8030 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8031 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8032 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8033 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8034 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8035 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8036 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8037 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8038 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8039 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8040 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8043 PL_last_swash_hv = Nullhv; /* reinits on demand */
8044 PL_last_swash_klen = 0;
8045 PL_last_swash_key[0]= '\0';
8046 PL_last_swash_tmps = (U8*)NULL;
8047 PL_last_swash_slen = 0;
8049 /* perly.c globals */
8050 PL_yydebug = proto_perl->Iyydebug;
8051 PL_yynerrs = proto_perl->Iyynerrs;
8052 PL_yyerrflag = proto_perl->Iyyerrflag;
8053 PL_yychar = proto_perl->Iyychar;
8054 PL_yyval = proto_perl->Iyyval;
8055 PL_yylval = proto_perl->Iyylval;
8057 PL_glob_index = proto_perl->Iglob_index;
8058 PL_srand_called = proto_perl->Isrand_called;
8059 PL_uudmap['M'] = 0; /* reinits on demand */
8060 PL_bitcount = Nullch; /* reinits on demand */
8062 if (proto_perl->Ipsig_ptr) {
8063 int sig_num[] = { SIG_NUM };
8064 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8065 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8066 for (i = 1; PL_sig_name[i]; i++) {
8067 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8068 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8072 PL_psig_ptr = (SV**)NULL;
8073 PL_psig_name = (SV**)NULL;
8076 /* thrdvar.h stuff */
8079 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8080 PL_tmps_ix = proto_perl->Ttmps_ix;
8081 PL_tmps_max = proto_perl->Ttmps_max;
8082 PL_tmps_floor = proto_perl->Ttmps_floor;
8083 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8085 while (i <= PL_tmps_ix) {
8086 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8090 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8091 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8092 Newz(54, PL_markstack, i, I32);
8093 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8094 - proto_perl->Tmarkstack);
8095 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8096 - proto_perl->Tmarkstack);
8097 Copy(proto_perl->Tmarkstack, PL_markstack,
8098 PL_markstack_ptr - PL_markstack + 1, I32);
8100 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8101 * NOTE: unlike the others! */
8102 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8103 PL_scopestack_max = proto_perl->Tscopestack_max;
8104 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8105 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8107 /* next push_return() sets PL_retstack[PL_retstack_ix]
8108 * NOTE: unlike the others! */
8109 PL_retstack_ix = proto_perl->Tretstack_ix;
8110 PL_retstack_max = proto_perl->Tretstack_max;
8111 Newz(54, PL_retstack, PL_retstack_max, OP*);
8112 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8114 /* NOTE: si_dup() looks at PL_markstack */
8115 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8117 /* PL_curstack = PL_curstackinfo->si_stack; */
8118 PL_curstack = av_dup(proto_perl->Tcurstack);
8119 PL_mainstack = av_dup(proto_perl->Tmainstack);
8121 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8122 PL_stack_base = AvARRAY(PL_curstack);
8123 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8124 - proto_perl->Tstack_base);
8125 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8127 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8128 * NOTE: unlike the others! */
8129 PL_savestack_ix = proto_perl->Tsavestack_ix;
8130 PL_savestack_max = proto_perl->Tsavestack_max;
8131 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8132 PL_savestack = ss_dup(proto_perl);
8136 ENTER; /* perl_destruct() wants to LEAVE; */
8139 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8140 PL_top_env = &PL_start_env;
8142 PL_op = proto_perl->Top;
8145 PL_Xpv = (XPV*)NULL;
8146 PL_na = proto_perl->Tna;
8148 PL_statbuf = proto_perl->Tstatbuf;
8149 PL_statcache = proto_perl->Tstatcache;
8150 PL_statgv = gv_dup(proto_perl->Tstatgv);
8151 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8153 PL_timesbuf = proto_perl->Ttimesbuf;
8156 PL_tainted = proto_perl->Ttainted;
8157 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8158 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8159 PL_rs = sv_dup_inc(proto_perl->Trs);
8160 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8161 PL_ofslen = proto_perl->Tofslen;
8162 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8163 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8164 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8165 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8166 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8167 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8169 PL_restartop = proto_perl->Trestartop;
8170 PL_in_eval = proto_perl->Tin_eval;
8171 PL_delaymagic = proto_perl->Tdelaymagic;
8172 PL_dirty = proto_perl->Tdirty;
8173 PL_localizing = proto_perl->Tlocalizing;
8175 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8176 PL_protect = proto_perl->Tprotect;
8178 PL_errors = sv_dup_inc(proto_perl->Terrors);
8179 PL_av_fetch_sv = Nullsv;
8180 PL_hv_fetch_sv = Nullsv;
8181 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8182 PL_modcount = proto_perl->Tmodcount;
8183 PL_lastgotoprobe = Nullop;
8184 PL_dumpindent = proto_perl->Tdumpindent;
8186 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8187 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8188 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8189 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8190 PL_sortcxix = proto_perl->Tsortcxix;
8191 PL_efloatbuf = Nullch; /* reinits on demand */
8192 PL_efloatsize = 0; /* reinits on demand */
8196 PL_screamfirst = NULL;
8197 PL_screamnext = NULL;
8198 PL_maxscream = -1; /* reinits on demand */
8199 PL_lastscream = Nullsv;
8201 PL_watchaddr = NULL;
8202 PL_watchok = Nullch;
8204 PL_regdummy = proto_perl->Tregdummy;
8205 PL_regcomp_parse = Nullch;
8206 PL_regxend = Nullch;
8207 PL_regcode = (regnode*)NULL;
8210 PL_regprecomp = Nullch;
8215 PL_seen_zerolen = 0;
8217 PL_regcomp_rx = (regexp*)NULL;
8219 PL_colorset = 0; /* reinits PL_colors[] */
8220 /*PL_colors[6] = {0,0,0,0,0,0};*/
8221 PL_reg_whilem_seen = 0;
8222 PL_reginput = Nullch;
8225 PL_regstartp = (I32*)NULL;
8226 PL_regendp = (I32*)NULL;
8227 PL_reglastparen = (U32*)NULL;
8228 PL_regtill = Nullch;
8230 PL_reg_start_tmp = (char**)NULL;
8231 PL_reg_start_tmpl = 0;
8232 PL_regdata = (struct reg_data*)NULL;
8235 PL_reg_eval_set = 0;
8237 PL_regprogram = (regnode*)NULL;
8239 PL_regcc = (CURCUR*)NULL;
8240 PL_reg_call_cc = (struct re_cc_state*)NULL;
8241 PL_reg_re = (regexp*)NULL;
8242 PL_reg_ganch = Nullch;
8244 PL_reg_magic = (MAGIC*)NULL;
8246 PL_reg_oldcurpm = (PMOP*)NULL;
8247 PL_reg_curpm = (PMOP*)NULL;
8248 PL_reg_oldsaved = Nullch;
8249 PL_reg_oldsavedlen = 0;
8251 PL_reg_leftiter = 0;
8252 PL_reg_poscache = Nullch;
8253 PL_reg_poscache_size= 0;
8255 /* RE engine - function pointers */
8256 PL_regcompp = proto_perl->Tregcompp;
8257 PL_regexecp = proto_perl->Tregexecp;
8258 PL_regint_start = proto_perl->Tregint_start;
8259 PL_regint_string = proto_perl->Tregint_string;
8260 PL_regfree = proto_perl->Tregfree;
8262 PL_reginterp_cnt = 0;
8263 PL_reg_starttry = 0;
8266 return (PerlInterpreter*)pPerl;
8272 #else /* !USE_ITHREADS */
8278 #endif /* USE_ITHREADS */
8281 do_report_used(pTHXo_ SV *sv)
8283 if (SvTYPE(sv) != SVTYPEMASK) {
8284 PerlIO_printf(Perl_debug_log, "****\n");
8290 do_clean_objs(pTHXo_ SV *sv)
8294 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8295 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8301 /* XXX Might want to check arrays, etc. */
8304 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8306 do_clean_named_objs(pTHXo_ SV *sv)
8308 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8309 if ( SvOBJECT(GvSV(sv)) ||
8310 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8311 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8312 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8313 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8315 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8323 do_clean_all(pTHXo_ SV *sv)
8325 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8326 SvFLAGS(sv) |= SVf_BREAK;