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: if (SvROK(sv))
2188 s = "SCALAR"; break;
2189 case SVt_PVLV: s = "LVALUE"; break;
2190 case SVt_PVAV: s = "ARRAY"; break;
2191 case SVt_PVHV: s = "HASH"; break;
2192 case SVt_PVCV: s = "CODE"; break;
2193 case SVt_PVGV: s = "GLOB"; break;
2194 case SVt_PVFM: s = "FORMAT"; break;
2195 case SVt_PVIO: s = "IO"; break;
2196 default: s = "UNKNOWN"; break;
2200 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2203 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2209 if (SvREADONLY(sv) && !SvOK(sv)) {
2211 if (ckWARN(WARN_UNINITIALIZED))
2217 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2218 /* XXXX 64-bit? IV may have better precision... */
2219 /* I tried changing this for to be 64-bit-aware and
2220 * the t/op/numconvert.t became very, very, angry.
2222 if (SvTYPE(sv) < SVt_PVNV)
2223 sv_upgrade(sv, SVt_PVNV);
2226 olderrno = errno; /* some Xenix systems wipe out errno here */
2228 if (SvNVX(sv) == 0.0)
2229 (void)strcpy(s,"0");
2233 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2236 #ifdef FIXNEGATIVEZERO
2237 if (*s == '-' && s[1] == '0' && !s[2])
2246 else if (SvIOKp(sv)) {
2247 U32 isIOK = SvIOK(sv);
2248 U32 isUIOK = SvIsUV(sv);
2249 char buf[TYPE_CHARS(UV)];
2252 if (SvTYPE(sv) < SVt_PVIV)
2253 sv_upgrade(sv, SVt_PVIV);
2255 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2257 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2258 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2259 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2260 SvCUR_set(sv, ebuf - ptr);
2273 if (ckWARN(WARN_UNINITIALIZED)
2274 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2279 if (SvTYPE(sv) < SVt_PV)
2280 /* Typically the caller expects that sv_any is not NULL now. */
2281 sv_upgrade(sv, SVt_PV);
2284 *lp = s - SvPVX(sv);
2287 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2288 PTR2UV(sv),SvPVX(sv)));
2292 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2293 /* Sneaky stuff here */
2297 tsv = newSVpv(tmpbuf, 0);
2313 len = strlen(tmpbuf);
2315 #ifdef FIXNEGATIVEZERO
2316 if (len == 2 && t[0] == '-' && t[1] == '0') {
2321 (void)SvUPGRADE(sv, SVt_PV);
2323 s = SvGROW(sv, len + 1);
2332 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2335 return sv_2pvbyte(sv, &n_a);
2339 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2341 return sv_2pv(sv,lp);
2345 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2348 return sv_2pvutf8(sv, &n_a);
2352 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2354 sv_utf8_upgrade(sv);
2355 return sv_2pv(sv,lp);
2358 /* This function is only called on magical items */
2360 Perl_sv_2bool(pTHX_ register SV *sv)
2370 if (SvAMAGIC(sv) && (tmpsv = AMG_CALLun(sv,bool_)))
2371 return SvTRUE(tmpsv);
2372 return SvRV(sv) != 0;
2375 register XPV* Xpvtmp;
2376 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2377 (*Xpvtmp->xpv_pv > '0' ||
2378 Xpvtmp->xpv_cur > 1 ||
2379 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2386 return SvIVX(sv) != 0;
2389 return SvNVX(sv) != 0.0;
2397 =for apidoc sv_utf8_upgrade
2399 Convert the PV of an SV to its UTF8-encoded form.
2405 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2410 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2413 /* This function could be much more efficient if we had a FLAG
2414 * to signal if there are any hibit chars in the string
2417 for (c = SvPVX(sv); c < SvEND(sv); c++) {
2424 SvGROW(sv, SvCUR(sv) + hicount + 1);
2426 src = SvEND(sv) - 1;
2427 SvCUR_set(sv, SvCUR(sv) + hicount);
2428 dst = SvEND(sv) - 1;
2433 uv_to_utf8((U8*)dst, (U8)*src--);
2446 =for apidoc sv_utf8_downgrade
2448 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2449 This may not be possible if the PV contains non-byte encoding characters;
2450 if this is the case, either returns false or, if C<fail_ok> is not
2457 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2459 if (SvPOK(sv) && SvUTF8(sv)) {
2460 char *c = SvPVX(sv);
2462 /* need to figure out if this is possible at all first */
2463 while (c < SvEND(sv)) {
2466 UV uv = utf8_to_uv((U8*)c, &len);
2471 /* XXX might want to make a callback here instead */
2472 Perl_croak(aTHX_ "Big byte");
2485 char *src = first_hi;
2486 char *dst = first_hi;
2487 while (src < SvEND(sv)) {
2490 U8 u = (U8)utf8_to_uv((U8*)src, &len);
2498 SvCUR_set(sv, dst - SvPVX(sv));
2506 =for apidoc sv_utf8_encode
2508 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2509 flag so that it looks like bytes again. Nothing calls this.
2515 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2517 sv_utf8_upgrade(sv);
2522 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2526 bool has_utf = FALSE;
2527 if (!sv_utf8_downgrade(sv, TRUE))
2530 /* it is actually just a matter of turning the utf8 flag on, but
2531 * we want to make sure everything inside is valid utf8 first.
2534 while (c < SvEND(sv)) {
2537 (void)utf8_to_uv((U8*)c, &len);
2557 /* Note: sv_setsv() should not be called with a source string that needs
2558 * to be reused, since it may destroy the source string if it is marked
2563 =for apidoc sv_setsv
2565 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2566 The source SV may be destroyed if it is mortal. Does not handle 'set'
2567 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2574 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2577 register U32 sflags;
2583 SV_CHECK_THINKFIRST(dstr);
2585 sstr = &PL_sv_undef;
2586 stype = SvTYPE(sstr);
2587 dtype = SvTYPE(dstr);
2591 /* There's a lot of redundancy below but we're going for speed here */
2596 if (dtype != SVt_PVGV) {
2597 (void)SvOK_off(dstr);
2605 sv_upgrade(dstr, SVt_IV);
2608 sv_upgrade(dstr, SVt_PVNV);
2612 sv_upgrade(dstr, SVt_PVIV);
2615 (void)SvIOK_only(dstr);
2616 SvIVX(dstr) = SvIVX(sstr);
2629 sv_upgrade(dstr, SVt_NV);
2634 sv_upgrade(dstr, SVt_PVNV);
2637 SvNVX(dstr) = SvNVX(sstr);
2638 (void)SvNOK_only(dstr);
2646 sv_upgrade(dstr, SVt_RV);
2647 else if (dtype == SVt_PVGV &&
2648 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2651 if (GvIMPORTED(dstr) != GVf_IMPORTED
2652 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2654 GvIMPORTED_on(dstr);
2665 sv_upgrade(dstr, SVt_PV);
2668 if (dtype < SVt_PVIV)
2669 sv_upgrade(dstr, SVt_PVIV);
2672 if (dtype < SVt_PVNV)
2673 sv_upgrade(dstr, SVt_PVNV);
2680 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2681 PL_op_name[PL_op->op_type]);
2683 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2687 if (dtype <= SVt_PVGV) {
2689 if (dtype != SVt_PVGV) {
2690 char *name = GvNAME(sstr);
2691 STRLEN len = GvNAMELEN(sstr);
2692 sv_upgrade(dstr, SVt_PVGV);
2693 sv_magic(dstr, dstr, '*', Nullch, 0);
2694 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2695 GvNAME(dstr) = savepvn(name, len);
2696 GvNAMELEN(dstr) = len;
2697 SvFAKE_on(dstr); /* can coerce to non-glob */
2699 /* ahem, death to those who redefine active sort subs */
2700 else if (PL_curstackinfo->si_type == PERLSI_SORT
2701 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2702 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2704 (void)SvOK_off(dstr);
2705 GvINTRO_off(dstr); /* one-shot flag */
2707 GvGP(dstr) = gp_ref(GvGP(sstr));
2709 if (GvIMPORTED(dstr) != GVf_IMPORTED
2710 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2712 GvIMPORTED_on(dstr);
2720 if (SvGMAGICAL(sstr)) {
2722 if (SvTYPE(sstr) != stype) {
2723 stype = SvTYPE(sstr);
2724 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2728 if (stype == SVt_PVLV)
2729 (void)SvUPGRADE(dstr, SVt_PVNV);
2731 (void)SvUPGRADE(dstr, stype);
2734 sflags = SvFLAGS(sstr);
2736 if (sflags & SVf_ROK) {
2737 if (dtype >= SVt_PV) {
2738 if (dtype == SVt_PVGV) {
2739 SV *sref = SvREFCNT_inc(SvRV(sstr));
2741 int intro = GvINTRO(dstr);
2746 GvINTRO_off(dstr); /* one-shot flag */
2747 Newz(602,gp, 1, GP);
2748 GvGP(dstr) = gp_ref(gp);
2749 GvSV(dstr) = NEWSV(72,0);
2750 GvLINE(dstr) = CopLINE(PL_curcop);
2751 GvEGV(dstr) = (GV*)dstr;
2754 switch (SvTYPE(sref)) {
2757 SAVESPTR(GvAV(dstr));
2759 dref = (SV*)GvAV(dstr);
2760 GvAV(dstr) = (AV*)sref;
2761 if (!GvIMPORTED_AV(dstr)
2762 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2764 GvIMPORTED_AV_on(dstr);
2769 SAVESPTR(GvHV(dstr));
2771 dref = (SV*)GvHV(dstr);
2772 GvHV(dstr) = (HV*)sref;
2773 if (!GvIMPORTED_HV(dstr)
2774 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2776 GvIMPORTED_HV_on(dstr);
2781 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2782 SvREFCNT_dec(GvCV(dstr));
2783 GvCV(dstr) = Nullcv;
2784 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2785 PL_sub_generation++;
2787 SAVESPTR(GvCV(dstr));
2790 dref = (SV*)GvCV(dstr);
2791 if (GvCV(dstr) != (CV*)sref) {
2792 CV* cv = GvCV(dstr);
2794 if (!GvCVGEN((GV*)dstr) &&
2795 (CvROOT(cv) || CvXSUB(cv)))
2797 SV *const_sv = cv_const_sv(cv);
2798 bool const_changed = TRUE;
2800 const_changed = sv_cmp(const_sv,
2801 op_const_sv(CvSTART((CV*)sref),
2803 /* ahem, death to those who redefine
2804 * active sort subs */
2805 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2806 PL_sortcop == CvSTART(cv))
2808 "Can't redefine active sort subroutine %s",
2809 GvENAME((GV*)dstr));
2810 if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE))
2811 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2812 "Constant subroutine %s redefined"
2813 : "Subroutine %s redefined",
2814 GvENAME((GV*)dstr));
2816 cv_ckproto(cv, (GV*)dstr,
2817 SvPOK(sref) ? SvPVX(sref) : Nullch);
2819 GvCV(dstr) = (CV*)sref;
2820 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2821 GvASSUMECV_on(dstr);
2822 PL_sub_generation++;
2824 if (!GvIMPORTED_CV(dstr)
2825 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2827 GvIMPORTED_CV_on(dstr);
2832 SAVESPTR(GvIOp(dstr));
2834 dref = (SV*)GvIOp(dstr);
2835 GvIOp(dstr) = (IO*)sref;
2839 SAVESPTR(GvFORM(dstr));
2841 dref = (SV*)GvFORM(dstr);
2842 GvFORM(dstr) = (CV*)sref;
2846 SAVESPTR(GvSV(dstr));
2848 dref = (SV*)GvSV(dstr);
2850 if (!GvIMPORTED_SV(dstr)
2851 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2853 GvIMPORTED_SV_on(dstr);
2865 (void)SvOOK_off(dstr); /* backoff */
2867 Safefree(SvPVX(dstr));
2868 SvLEN(dstr)=SvCUR(dstr)=0;
2871 (void)SvOK_off(dstr);
2872 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2874 if (sflags & SVp_NOK) {
2876 SvNVX(dstr) = SvNVX(sstr);
2878 if (sflags & SVp_IOK) {
2879 (void)SvIOK_on(dstr);
2880 SvIVX(dstr) = SvIVX(sstr);
2881 if (sflags & SVf_IVisUV)
2884 if (SvAMAGIC(sstr)) {
2888 else if (sflags & SVp_POK) {
2891 * Check to see if we can just swipe the string. If so, it's a
2892 * possible small lose on short strings, but a big win on long ones.
2893 * It might even be a win on short strings if SvPVX(dstr)
2894 * has to be allocated and SvPVX(sstr) has to be freed.
2897 if (SvTEMP(sstr) && /* slated for free anyway? */
2898 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2899 !(sflags & SVf_OOK)) /* and not involved in OOK hack? */
2901 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2903 SvFLAGS(dstr) &= ~SVf_OOK;
2904 Safefree(SvPVX(dstr) - SvIVX(dstr));
2906 else if (SvLEN(dstr))
2907 Safefree(SvPVX(dstr));
2909 (void)SvPOK_only(dstr);
2910 SvPV_set(dstr, SvPVX(sstr));
2911 SvLEN_set(dstr, SvLEN(sstr));
2912 SvCUR_set(dstr, SvCUR(sstr));
2915 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
2916 SvPV_set(sstr, Nullch);
2921 else { /* have to copy actual string */
2922 STRLEN len = SvCUR(sstr);
2924 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2925 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2926 SvCUR_set(dstr, len);
2927 *SvEND(dstr) = '\0';
2928 (void)SvPOK_only(dstr);
2930 if ((sflags & SVf_UTF8) && !IN_BYTE)
2933 if (sflags & SVp_NOK) {
2935 SvNVX(dstr) = SvNVX(sstr);
2937 if (sflags & SVp_IOK) {
2938 (void)SvIOK_on(dstr);
2939 SvIVX(dstr) = SvIVX(sstr);
2940 if (sflags & SVf_IVisUV)
2944 else if (sflags & SVp_NOK) {
2945 SvNVX(dstr) = SvNVX(sstr);
2946 (void)SvNOK_only(dstr);
2947 if (sflags & SVf_IOK) {
2948 (void)SvIOK_on(dstr);
2949 SvIVX(dstr) = SvIVX(sstr);
2950 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2951 if (sflags & SVf_IVisUV)
2955 else if (sflags & SVp_IOK) {
2956 (void)SvIOK_only(dstr);
2957 SvIVX(dstr) = SvIVX(sstr);
2958 if (sflags & SVf_IVisUV)
2962 if (dtype == SVt_PVGV) {
2963 if (ckWARN(WARN_MISC))
2964 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2967 (void)SvOK_off(dstr);
2973 =for apidoc sv_setsv_mg
2975 Like C<sv_setsv>, but also handles 'set' magic.
2981 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2983 sv_setsv(dstr,sstr);
2988 =for apidoc sv_setpvn
2990 Copies a string into an SV. The C<len> parameter indicates the number of
2991 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2997 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2999 register char *dptr;
3000 assert(len >= 0); /* STRLEN is probably unsigned, so this may
3001 elicit a warning, but it won't hurt. */
3002 SV_CHECK_THINKFIRST(sv);
3007 (void)SvUPGRADE(sv, SVt_PV);
3009 SvGROW(sv, len + 1);
3011 Move(ptr,dptr,len,char);
3014 (void)SvPOK_only(sv); /* validate pointer */
3019 =for apidoc sv_setpvn_mg
3021 Like C<sv_setpvn>, but also handles 'set' magic.
3027 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3029 sv_setpvn(sv,ptr,len);
3034 =for apidoc sv_setpv
3036 Copies a string into an SV. The string must be null-terminated. Does not
3037 handle 'set' magic. See C<sv_setpv_mg>.
3043 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3045 register STRLEN len;
3047 SV_CHECK_THINKFIRST(sv);
3053 (void)SvUPGRADE(sv, SVt_PV);
3055 SvGROW(sv, len + 1);
3056 Move(ptr,SvPVX(sv),len+1,char);
3058 (void)SvPOK_only(sv); /* validate pointer */
3063 =for apidoc sv_setpv_mg
3065 Like C<sv_setpv>, but also handles 'set' magic.
3071 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3078 =for apidoc sv_usepvn
3080 Tells an SV to use C<ptr> to find its string value. Normally the string is
3081 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3082 The C<ptr> should point to memory that was allocated by C<malloc>. The
3083 string length, C<len>, must be supplied. This function will realloc the
3084 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3085 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3086 See C<sv_usepvn_mg>.
3092 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3094 SV_CHECK_THINKFIRST(sv);
3095 (void)SvUPGRADE(sv, SVt_PV);
3100 (void)SvOOK_off(sv);
3101 if (SvPVX(sv) && SvLEN(sv))
3102 Safefree(SvPVX(sv));
3103 Renew(ptr, len+1, char);
3106 SvLEN_set(sv, len+1);
3108 (void)SvPOK_only(sv); /* validate pointer */
3113 =for apidoc sv_usepvn_mg
3115 Like C<sv_usepvn>, but also handles 'set' magic.
3121 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3123 sv_usepvn(sv,ptr,len);
3128 Perl_sv_force_normal(pTHX_ register SV *sv)
3130 if (SvREADONLY(sv)) {
3132 if (PL_curcop != &PL_compiling)
3133 Perl_croak(aTHX_ PL_no_modify);
3137 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3144 Efficient removal of characters from the beginning of the string buffer.
3145 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3146 the string buffer. The C<ptr> becomes the first character of the adjusted
3153 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3157 register STRLEN delta;
3159 if (!ptr || !SvPOKp(sv))
3161 SV_CHECK_THINKFIRST(sv);
3162 if (SvTYPE(sv) < SVt_PVIV)
3163 sv_upgrade(sv,SVt_PVIV);
3166 if (!SvLEN(sv)) { /* make copy of shared string */
3167 char *pvx = SvPVX(sv);
3168 STRLEN len = SvCUR(sv);
3169 SvGROW(sv, len + 1);
3170 Move(pvx,SvPVX(sv),len,char);
3174 SvFLAGS(sv) |= SVf_OOK;
3176 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3177 delta = ptr - SvPVX(sv);
3185 =for apidoc sv_catpvn
3187 Concatenates the string onto the end of the string which is in the SV. The
3188 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3189 'set' magic. See C<sv_catpvn_mg>.
3195 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3200 junk = SvPV_force(sv, tlen);
3201 SvGROW(sv, tlen + len + 1);
3204 Move(ptr,SvPVX(sv)+tlen,len,char);
3207 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3212 =for apidoc sv_catpvn_mg
3214 Like C<sv_catpvn>, but also handles 'set' magic.
3220 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3222 sv_catpvn(sv,ptr,len);
3227 =for apidoc sv_catsv
3229 Concatenates the string from SV C<ssv> onto the end of the string in SV
3230 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3236 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3242 if ((s = SvPV(sstr, len))) {
3243 if (DO_UTF8(sstr)) {
3244 sv_utf8_upgrade(dstr);
3245 sv_catpvn(dstr,s,len);
3249 sv_catpvn(dstr,s,len);
3254 =for apidoc sv_catsv_mg
3256 Like C<sv_catsv>, but also handles 'set' magic.
3262 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3264 sv_catsv(dstr,sstr);
3269 =for apidoc sv_catpv
3271 Concatenates the string onto the end of the string which is in the SV.
3272 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3278 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3280 register STRLEN len;
3286 junk = SvPV_force(sv, tlen);
3288 SvGROW(sv, tlen + len + 1);
3291 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3293 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3298 =for apidoc sv_catpv_mg
3300 Like C<sv_catpv>, but also handles 'set' magic.
3306 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3313 Perl_newSV(pTHX_ STRLEN len)
3319 sv_upgrade(sv, SVt_PV);
3320 SvGROW(sv, len + 1);
3325 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3328 =for apidoc sv_magic
3330 Adds magic to an SV.
3336 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3340 if (SvREADONLY(sv)) {
3342 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3343 Perl_croak(aTHX_ PL_no_modify);
3345 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3346 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3353 (void)SvUPGRADE(sv, SVt_PVMG);
3355 Newz(702,mg, 1, MAGIC);
3356 mg->mg_moremagic = SvMAGIC(sv);
3359 if (!obj || obj == sv || how == '#' || how == 'r')
3363 mg->mg_obj = SvREFCNT_inc(obj);
3364 mg->mg_flags |= MGf_REFCOUNTED;
3367 mg->mg_len = namlen;
3370 mg->mg_ptr = savepvn(name, namlen);
3371 else if (namlen == HEf_SVKEY)
3372 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3376 mg->mg_virtual = &PL_vtbl_sv;
3379 mg->mg_virtual = &PL_vtbl_amagic;
3382 mg->mg_virtual = &PL_vtbl_amagicelem;
3388 mg->mg_virtual = &PL_vtbl_bm;
3391 mg->mg_virtual = &PL_vtbl_regdata;
3394 mg->mg_virtual = &PL_vtbl_regdatum;
3397 mg->mg_virtual = &PL_vtbl_env;
3400 mg->mg_virtual = &PL_vtbl_fm;
3403 mg->mg_virtual = &PL_vtbl_envelem;
3406 mg->mg_virtual = &PL_vtbl_mglob;
3409 mg->mg_virtual = &PL_vtbl_isa;
3412 mg->mg_virtual = &PL_vtbl_isaelem;
3415 mg->mg_virtual = &PL_vtbl_nkeys;
3422 mg->mg_virtual = &PL_vtbl_dbline;
3426 mg->mg_virtual = &PL_vtbl_mutex;
3428 #endif /* USE_THREADS */
3429 #ifdef USE_LOCALE_COLLATE
3431 mg->mg_virtual = &PL_vtbl_collxfrm;
3433 #endif /* USE_LOCALE_COLLATE */
3435 mg->mg_virtual = &PL_vtbl_pack;
3439 mg->mg_virtual = &PL_vtbl_packelem;
3442 mg->mg_virtual = &PL_vtbl_regexp;
3445 mg->mg_virtual = &PL_vtbl_sig;
3448 mg->mg_virtual = &PL_vtbl_sigelem;
3451 mg->mg_virtual = &PL_vtbl_taint;
3455 mg->mg_virtual = &PL_vtbl_uvar;
3458 mg->mg_virtual = &PL_vtbl_vec;
3461 mg->mg_virtual = &PL_vtbl_substr;
3464 mg->mg_virtual = &PL_vtbl_defelem;
3467 mg->mg_virtual = &PL_vtbl_glob;
3470 mg->mg_virtual = &PL_vtbl_arylen;
3473 mg->mg_virtual = &PL_vtbl_pos;
3476 mg->mg_virtual = &PL_vtbl_backref;
3478 case '~': /* Reserved for use by extensions not perl internals. */
3479 /* Useful for attaching extension internal data to perl vars. */
3480 /* Note that multiple extensions may clash if magical scalars */
3481 /* etc holding private data from one are passed to another. */
3485 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3489 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3493 =for apidoc sv_unmagic
3495 Removes magic from an SV.
3501 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3505 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3508 for (mg = *mgp; mg; mg = *mgp) {
3509 if (mg->mg_type == type) {
3510 MGVTBL* vtbl = mg->mg_virtual;
3511 *mgp = mg->mg_moremagic;
3512 if (vtbl && vtbl->svt_free)
3513 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3514 if (mg->mg_ptr && mg->mg_type != 'g')
3515 if (mg->mg_len >= 0)
3516 Safefree(mg->mg_ptr);
3517 else if (mg->mg_len == HEf_SVKEY)
3518 SvREFCNT_dec((SV*)mg->mg_ptr);
3519 if (mg->mg_flags & MGf_REFCOUNTED)
3520 SvREFCNT_dec(mg->mg_obj);
3524 mgp = &mg->mg_moremagic;
3528 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3535 =for apidoc sv_rvweaken
3543 Perl_sv_rvweaken(pTHX_ SV *sv)
3546 if (!SvOK(sv)) /* let undefs pass */
3549 Perl_croak(aTHX_ "Can't weaken a nonreference");
3550 else if (SvWEAKREF(sv)) {
3552 if (ckWARN(WARN_MISC))
3553 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3557 sv_add_backref(tsv, sv);
3564 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3568 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3569 av = (AV*)mg->mg_obj;
3572 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3573 SvREFCNT_dec(av); /* for sv_magic */
3579 S_sv_del_backref(pTHX_ SV *sv)
3586 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3587 Perl_croak(aTHX_ "panic: del_backref");
3588 av = (AV *)mg->mg_obj;
3593 svp[i] = &PL_sv_undef; /* XXX */
3600 =for apidoc sv_insert
3602 Inserts a string at the specified offset/length within the SV. Similar to
3603 the Perl substr() function.
3609 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3613 register char *midend;
3614 register char *bigend;
3620 Perl_croak(aTHX_ "Can't modify non-existent substring");
3621 SvPV_force(bigstr, curlen);
3622 (void)SvPOK_only_UTF8(bigstr);
3623 if (offset + len > curlen) {
3624 SvGROW(bigstr, offset+len+1);
3625 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3626 SvCUR_set(bigstr, offset+len);
3630 i = littlelen - len;
3631 if (i > 0) { /* string might grow */
3632 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3633 mid = big + offset + len;
3634 midend = bigend = big + SvCUR(bigstr);
3637 while (midend > mid) /* shove everything down */
3638 *--bigend = *--midend;
3639 Move(little,big+offset,littlelen,char);
3645 Move(little,SvPVX(bigstr)+offset,len,char);
3650 big = SvPVX(bigstr);
3653 bigend = big + SvCUR(bigstr);
3655 if (midend > bigend)
3656 Perl_croak(aTHX_ "panic: sv_insert");
3658 if (mid - big > bigend - midend) { /* faster to shorten from end */
3660 Move(little, mid, littlelen,char);
3663 i = bigend - midend;
3665 Move(midend, mid, i,char);
3669 SvCUR_set(bigstr, mid - big);
3672 else if ((i = mid - big)) { /* faster from front */
3673 midend -= littlelen;
3675 sv_chop(bigstr,midend-i);
3680 Move(little, mid, littlelen,char);
3682 else if (littlelen) {
3683 midend -= littlelen;
3684 sv_chop(bigstr,midend);
3685 Move(little,midend,littlelen,char);
3688 sv_chop(bigstr,midend);
3694 =for apidoc sv_replace
3696 Make the first argument a copy of the second, then delete the original.
3702 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3705 U32 refcnt = SvREFCNT(sv);
3706 SV_CHECK_THINKFIRST(sv);
3707 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3708 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3709 if (SvMAGICAL(sv)) {
3713 sv_upgrade(nsv, SVt_PVMG);
3714 SvMAGIC(nsv) = SvMAGIC(sv);
3715 SvFLAGS(nsv) |= SvMAGICAL(sv);
3721 assert(!SvREFCNT(sv));
3722 StructCopy(nsv,sv,SV);
3723 SvREFCNT(sv) = refcnt;
3724 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3729 =for apidoc sv_clear
3731 Clear an SV, making it empty. Does not free the memory used by the SV
3738 Perl_sv_clear(pTHX_ register SV *sv)
3742 assert(SvREFCNT(sv) == 0);
3746 if (PL_defstash) { /* Still have a symbol table? */
3751 Zero(&tmpref, 1, SV);
3752 sv_upgrade(&tmpref, SVt_RV);
3754 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3755 SvREFCNT(&tmpref) = 1;
3758 stash = SvSTASH(sv);
3759 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3762 PUSHSTACKi(PERLSI_DESTROY);
3763 SvRV(&tmpref) = SvREFCNT_inc(sv);
3768 call_sv((SV*)GvCV(destructor),
3769 G_DISCARD|G_EVAL|G_KEEPERR);
3775 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3777 del_XRV(SvANY(&tmpref));
3780 if (PL_in_clean_objs)
3781 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3783 /* DESTROY gave object new lease on life */
3789 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3790 SvOBJECT_off(sv); /* Curse the object. */
3791 if (SvTYPE(sv) != SVt_PVIO)
3792 --PL_sv_objcount; /* XXX Might want something more general */
3795 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3798 switch (SvTYPE(sv)) {
3801 IoIFP(sv) != PerlIO_stdin() &&
3802 IoIFP(sv) != PerlIO_stdout() &&
3803 IoIFP(sv) != PerlIO_stderr())
3805 io_close((IO*)sv, FALSE);
3807 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3808 PerlDir_close(IoDIRP(sv));
3809 IoDIRP(sv) = (DIR*)NULL;
3810 Safefree(IoTOP_NAME(sv));
3811 Safefree(IoFMT_NAME(sv));
3812 Safefree(IoBOTTOM_NAME(sv));
3827 SvREFCNT_dec(LvTARG(sv));
3831 Safefree(GvNAME(sv));
3832 /* cannot decrease stash refcount yet, as we might recursively delete
3833 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3834 of stash until current sv is completely gone.
3835 -- JohnPC, 27 Mar 1998 */
3836 stash = GvSTASH(sv);
3842 (void)SvOOK_off(sv);
3850 SvREFCNT_dec(SvRV(sv));
3852 else if (SvPVX(sv) && SvLEN(sv))
3853 Safefree(SvPVX(sv));
3863 switch (SvTYPE(sv)) {
3879 del_XPVIV(SvANY(sv));
3882 del_XPVNV(SvANY(sv));
3885 del_XPVMG(SvANY(sv));
3888 del_XPVLV(SvANY(sv));
3891 del_XPVAV(SvANY(sv));
3894 del_XPVHV(SvANY(sv));
3897 del_XPVCV(SvANY(sv));
3900 del_XPVGV(SvANY(sv));
3901 /* code duplication for increased performance. */
3902 SvFLAGS(sv) &= SVf_BREAK;
3903 SvFLAGS(sv) |= SVTYPEMASK;
3904 /* decrease refcount of the stash that owns this GV, if any */
3906 SvREFCNT_dec(stash);
3907 return; /* not break, SvFLAGS reset already happened */
3909 del_XPVBM(SvANY(sv));
3912 del_XPVFM(SvANY(sv));
3915 del_XPVIO(SvANY(sv));
3918 SvFLAGS(sv) &= SVf_BREAK;
3919 SvFLAGS(sv) |= SVTYPEMASK;
3923 Perl_sv_newref(pTHX_ SV *sv)
3926 ATOMIC_INC(SvREFCNT(sv));
3933 Free the memory used by an SV.
3939 Perl_sv_free(pTHX_ SV *sv)
3942 int refcount_is_zero;
3946 if (SvREFCNT(sv) == 0) {
3947 if (SvFLAGS(sv) & SVf_BREAK)
3949 if (PL_in_clean_all) /* All is fair */
3951 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3952 /* make sure SvREFCNT(sv)==0 happens very seldom */
3953 SvREFCNT(sv) = (~(U32)0)/2;
3956 if (ckWARN_d(WARN_INTERNAL))
3957 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3960 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3961 if (!refcount_is_zero)
3965 if (ckWARN_d(WARN_DEBUGGING))
3966 Perl_warner(aTHX_ WARN_DEBUGGING,
3967 "Attempt to free temp prematurely: SV 0x%"UVxf,
3972 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3973 /* make sure SvREFCNT(sv)==0 happens very seldom */
3974 SvREFCNT(sv) = (~(U32)0)/2;
3985 Returns the length of the string in the SV. See also C<SvCUR>.
3991 Perl_sv_len(pTHX_ register SV *sv)
4000 len = mg_length(sv);
4002 junk = SvPV(sv, len);
4007 =for apidoc sv_len_utf8
4009 Returns the number of characters in the string in an SV, counting wide
4010 UTF8 bytes as a single character.
4016 Perl_sv_len_utf8(pTHX_ register SV *sv)
4027 len = mg_length(sv);
4030 s = (U8*)SvPV(sv, len);
4041 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4046 I32 uoffset = *offsetp;
4052 start = s = (U8*)SvPV(sv, len);
4054 while (s < send && uoffset--)
4058 *offsetp = s - start;
4062 while (s < send && ulen--)
4072 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4081 s = (U8*)SvPV(sv, len);
4083 Perl_croak(aTHX_ "panic: bad byte offset");
4084 send = s + *offsetp;
4092 if (ckWARN_d(WARN_UTF8))
4093 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4103 Returns a boolean indicating whether the strings in the two SVs are
4110 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4117 bool pv1tmp = FALSE;
4118 bool pv2tmp = FALSE;
4125 pv1 = SvPV(sv1, cur1);
4132 pv2 = SvPV(sv2, cur2);
4134 /* do not utf8ize the comparands as a side-effect */
4135 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE && 0) {
4137 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4141 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4147 eq = memEQ(pv1, pv2, cur1);
4160 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4161 string in C<sv1> is less than, equal to, or greater than the string in
4168 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4173 bool pv1tmp = FALSE;
4174 bool pv2tmp = FALSE;
4181 pv1 = SvPV(sv1, cur1);
4188 pv2 = SvPV(sv2, cur2);
4190 /* do not utf8ize the comparands as a side-effect */
4191 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4193 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4197 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4203 cmp = cur2 ? -1 : 0;
4207 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4210 cmp = retval < 0 ? -1 : 1;
4211 } else if (cur1 == cur2) {
4214 cmp = cur1 < cur2 ? -1 : 1;
4227 =for apidoc sv_cmp_locale
4229 Compares the strings in two SVs in a locale-aware manner. See
4236 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4238 #ifdef USE_LOCALE_COLLATE
4244 if (PL_collation_standard)
4248 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4250 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4252 if (!pv1 || !len1) {
4263 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4266 return retval < 0 ? -1 : 1;
4269 * When the result of collation is equality, that doesn't mean
4270 * that there are no differences -- some locales exclude some
4271 * characters from consideration. So to avoid false equalities,
4272 * we use the raw string as a tiebreaker.
4278 #endif /* USE_LOCALE_COLLATE */
4280 return sv_cmp(sv1, sv2);
4283 #ifdef USE_LOCALE_COLLATE
4285 * Any scalar variable may carry an 'o' magic that contains the
4286 * scalar data of the variable transformed to such a format that
4287 * a normal memory comparison can be used to compare the data
4288 * according to the locale settings.
4291 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4295 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4296 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4301 Safefree(mg->mg_ptr);
4303 if ((xf = mem_collxfrm(s, len, &xlen))) {
4304 if (SvREADONLY(sv)) {
4307 return xf + sizeof(PL_collation_ix);
4310 sv_magic(sv, 0, 'o', 0, 0);
4311 mg = mg_find(sv, 'o');
4324 if (mg && mg->mg_ptr) {
4326 return mg->mg_ptr + sizeof(PL_collation_ix);
4334 #endif /* USE_LOCALE_COLLATE */
4339 Get a line from the filehandle and store it into the SV, optionally
4340 appending to the currently-stored string.
4346 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4351 register STDCHAR rslast;
4352 register STDCHAR *bp;
4356 SV_CHECK_THINKFIRST(sv);
4357 (void)SvUPGRADE(sv, SVt_PV);
4361 if (RsSNARF(PL_rs)) {
4365 else if (RsRECORD(PL_rs)) {
4366 I32 recsize, bytesread;
4369 /* Grab the size of the record we're getting */
4370 recsize = SvIV(SvRV(PL_rs));
4371 (void)SvPOK_only(sv); /* Validate pointer */
4372 buffer = SvGROW(sv, recsize + 1);
4375 /* VMS wants read instead of fread, because fread doesn't respect */
4376 /* RMS record boundaries. This is not necessarily a good thing to be */
4377 /* doing, but we've got no other real choice */
4378 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4380 bytesread = PerlIO_read(fp, buffer, recsize);
4382 SvCUR_set(sv, bytesread);
4383 buffer[bytesread] = '\0';
4384 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4386 else if (RsPARA(PL_rs)) {
4391 rsptr = SvPV(PL_rs, rslen);
4392 rslast = rslen ? rsptr[rslen - 1] : '\0';
4394 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4395 do { /* to make sure file boundaries work right */
4398 i = PerlIO_getc(fp);
4402 PerlIO_ungetc(fp,i);
4408 /* See if we know enough about I/O mechanism to cheat it ! */
4410 /* This used to be #ifdef test - it is made run-time test for ease
4411 of abstracting out stdio interface. One call should be cheap
4412 enough here - and may even be a macro allowing compile
4416 if (PerlIO_fast_gets(fp)) {
4419 * We're going to steal some values from the stdio struct
4420 * and put EVERYTHING in the innermost loop into registers.
4422 register STDCHAR *ptr;
4426 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4427 /* An ungetc()d char is handled separately from the regular
4428 * buffer, so we getc() it back out and stuff it in the buffer.
4430 i = PerlIO_getc(fp);
4431 if (i == EOF) return 0;
4432 *(--((*fp)->_ptr)) = (unsigned char) i;
4436 /* Here is some breathtakingly efficient cheating */
4438 cnt = PerlIO_get_cnt(fp); /* get count into register */
4439 (void)SvPOK_only(sv); /* validate pointer */
4440 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4441 if (cnt > 80 && SvLEN(sv) > append) {
4442 shortbuffered = cnt - SvLEN(sv) + append + 1;
4443 cnt -= shortbuffered;
4447 /* remember that cnt can be negative */
4448 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4453 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4454 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4455 DEBUG_P(PerlIO_printf(Perl_debug_log,
4456 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4457 DEBUG_P(PerlIO_printf(Perl_debug_log,
4458 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4459 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4460 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4465 while (cnt > 0) { /* this | eat */
4467 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4468 goto thats_all_folks; /* screams | sed :-) */
4472 Copy(ptr, bp, cnt, char); /* this | eat */
4473 bp += cnt; /* screams | dust */
4474 ptr += cnt; /* louder | sed :-) */
4479 if (shortbuffered) { /* oh well, must extend */
4480 cnt = shortbuffered;
4482 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4484 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4485 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4489 DEBUG_P(PerlIO_printf(Perl_debug_log,
4490 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4491 PTR2UV(ptr),(long)cnt));
4492 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4493 DEBUG_P(PerlIO_printf(Perl_debug_log,
4494 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4495 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4496 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4497 /* This used to call 'filbuf' in stdio form, but as that behaves like
4498 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4499 another abstraction. */
4500 i = PerlIO_getc(fp); /* get more characters */
4501 DEBUG_P(PerlIO_printf(Perl_debug_log,
4502 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4503 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4504 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4505 cnt = PerlIO_get_cnt(fp);
4506 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4507 DEBUG_P(PerlIO_printf(Perl_debug_log,
4508 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4510 if (i == EOF) /* all done for ever? */
4511 goto thats_really_all_folks;
4513 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4515 SvGROW(sv, bpx + cnt + 2);
4516 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4518 *bp++ = i; /* store character from PerlIO_getc */
4520 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4521 goto thats_all_folks;
4525 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4526 memNE((char*)bp - rslen, rsptr, rslen))
4527 goto screamer; /* go back to the fray */
4528 thats_really_all_folks:
4530 cnt += shortbuffered;
4531 DEBUG_P(PerlIO_printf(Perl_debug_log,
4532 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4533 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4534 DEBUG_P(PerlIO_printf(Perl_debug_log,
4535 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4536 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4537 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4539 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4540 DEBUG_P(PerlIO_printf(Perl_debug_log,
4541 "Screamer: done, len=%ld, string=|%.*s|\n",
4542 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4547 /*The big, slow, and stupid way */
4550 /* Need to work around EPOC SDK features */
4551 /* On WINS: MS VC5 generates calls to _chkstk, */
4552 /* if a `large' stack frame is allocated */
4553 /* gcc on MARM does not generate calls like these */
4559 register STDCHAR *bpe = buf + sizeof(buf);
4561 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4562 ; /* keep reading */
4566 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4567 /* Accomodate broken VAXC compiler, which applies U8 cast to
4568 * both args of ?: operator, causing EOF to change into 255
4570 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4574 sv_catpvn(sv, (char *) buf, cnt);
4576 sv_setpvn(sv, (char *) buf, cnt);
4578 if (i != EOF && /* joy */
4580 SvCUR(sv) < rslen ||
4581 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4585 * If we're reading from a TTY and we get a short read,
4586 * indicating that the user hit his EOF character, we need
4587 * to notice it now, because if we try to read from the TTY
4588 * again, the EOF condition will disappear.
4590 * The comparison of cnt to sizeof(buf) is an optimization
4591 * that prevents unnecessary calls to feof().
4595 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4600 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4601 while (i != EOF) { /* to make sure file boundaries work right */
4602 i = PerlIO_getc(fp);
4604 PerlIO_ungetc(fp,i);
4610 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4617 Auto-increment of the value in the SV.
4623 Perl_sv_inc(pTHX_ register SV *sv)
4632 if (SvTHINKFIRST(sv)) {
4633 if (SvREADONLY(sv)) {
4635 if (PL_curcop != &PL_compiling)
4636 Perl_croak(aTHX_ PL_no_modify);
4640 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4642 i = PTR2IV(SvRV(sv));
4647 flags = SvFLAGS(sv);
4648 if (flags & SVp_NOK) {
4649 (void)SvNOK_only(sv);
4653 if (flags & SVp_IOK) {
4655 if (SvUVX(sv) == UV_MAX)
4656 sv_setnv(sv, (NV)UV_MAX + 1.0);
4658 (void)SvIOK_only_UV(sv);
4661 if (SvIVX(sv) == IV_MAX)
4662 sv_setnv(sv, (NV)IV_MAX + 1.0);
4664 (void)SvIOK_only(sv);
4670 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4671 if ((flags & SVTYPEMASK) < SVt_PVNV)
4672 sv_upgrade(sv, SVt_NV);
4674 (void)SvNOK_only(sv);
4678 while (isALPHA(*d)) d++;
4679 while (isDIGIT(*d)) d++;
4681 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4685 while (d >= SvPVX(sv)) {
4693 /* MKS: The original code here died if letters weren't consecutive.
4694 * at least it didn't have to worry about non-C locales. The
4695 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4696 * arranged in order (although not consecutively) and that only
4697 * [A-Za-z] are accepted by isALPHA in the C locale.
4699 if (*d != 'z' && *d != 'Z') {
4700 do { ++*d; } while (!isALPHA(*d));
4703 *(d--) -= 'z' - 'a';
4708 *(d--) -= 'z' - 'a' + 1;
4712 /* oh,oh, the number grew */
4713 SvGROW(sv, SvCUR(sv) + 2);
4715 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4726 Auto-decrement of the value in the SV.
4732 Perl_sv_dec(pTHX_ register SV *sv)
4740 if (SvTHINKFIRST(sv)) {
4741 if (SvREADONLY(sv)) {
4743 if (PL_curcop != &PL_compiling)
4744 Perl_croak(aTHX_ PL_no_modify);
4748 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4750 i = PTR2IV(SvRV(sv));
4755 flags = SvFLAGS(sv);
4756 if (flags & SVp_NOK) {
4758 (void)SvNOK_only(sv);
4761 if (flags & SVp_IOK) {
4763 if (SvUVX(sv) == 0) {
4764 (void)SvIOK_only(sv);
4768 (void)SvIOK_only_UV(sv);
4772 if (SvIVX(sv) == IV_MIN)
4773 sv_setnv(sv, (NV)IV_MIN - 1.0);
4775 (void)SvIOK_only(sv);
4781 if (!(flags & SVp_POK)) {
4782 if ((flags & SVTYPEMASK) < SVt_PVNV)
4783 sv_upgrade(sv, SVt_NV);
4785 (void)SvNOK_only(sv);
4788 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4792 =for apidoc sv_mortalcopy
4794 Creates a new SV which is a copy of the original SV. The new SV is marked
4800 /* Make a string that will exist for the duration of the expression
4801 * evaluation. Actually, it may have to last longer than that, but
4802 * hopefully we won't free it until it has been assigned to a
4803 * permanent location. */
4806 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4812 sv_setsv(sv,oldstr);
4814 PL_tmps_stack[++PL_tmps_ix] = sv;
4820 =for apidoc sv_newmortal
4822 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4828 Perl_sv_newmortal(pTHX)
4834 SvFLAGS(sv) = SVs_TEMP;
4836 PL_tmps_stack[++PL_tmps_ix] = sv;
4841 =for apidoc sv_2mortal
4843 Marks an SV as mortal. The SV will be destroyed when the current context
4849 /* same thing without the copying */
4852 Perl_sv_2mortal(pTHX_ register SV *sv)
4857 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4860 PL_tmps_stack[++PL_tmps_ix] = sv;
4868 Creates a new SV and copies a string into it. The reference count for the
4869 SV is set to 1. If C<len> is zero, Perl will compute the length using
4870 strlen(). For efficiency, consider using C<newSVpvn> instead.
4876 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4883 sv_setpvn(sv,s,len);
4888 =for apidoc newSVpvn
4890 Creates a new SV and copies a string into it. The reference count for the
4891 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4892 string. You are responsible for ensuring that the source string is at least
4899 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4904 sv_setpvn(sv,s,len);
4908 #if defined(PERL_IMPLICIT_CONTEXT)
4910 Perl_newSVpvf_nocontext(const char* pat, ...)
4915 va_start(args, pat);
4916 sv = vnewSVpvf(pat, &args);
4923 =for apidoc newSVpvf
4925 Creates a new SV an initialize it with the string formatted like
4932 Perl_newSVpvf(pTHX_ const char* pat, ...)
4936 va_start(args, pat);
4937 sv = vnewSVpvf(pat, &args);
4943 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4947 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4954 Creates a new SV and copies a floating point value into it.
4955 The reference count for the SV is set to 1.
4961 Perl_newSVnv(pTHX_ NV n)
4973 Creates a new SV and copies an integer into it. The reference count for the
4980 Perl_newSViv(pTHX_ IV i)
4992 Creates a new SV and copies an unsigned integer into it.
4993 The reference count for the SV is set to 1.
4999 Perl_newSVuv(pTHX_ UV u)
5009 =for apidoc newRV_noinc
5011 Creates an RV wrapper for an SV. The reference count for the original
5012 SV is B<not> incremented.
5018 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5024 sv_upgrade(sv, SVt_RV);
5031 /* newRV_inc is #defined to newRV in sv.h */
5033 Perl_newRV(pTHX_ SV *tmpRef)
5035 return newRV_noinc(SvREFCNT_inc(tmpRef));
5041 Creates a new SV which is an exact duplicate of the original SV.
5046 /* make an exact duplicate of old */
5049 Perl_newSVsv(pTHX_ register SV *old)
5056 if (SvTYPE(old) == SVTYPEMASK) {
5057 if (ckWARN_d(WARN_INTERNAL))
5058 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5073 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5081 char todo[PERL_UCHAR_MAX+1];
5086 if (!*s) { /* reset ?? searches */
5087 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5088 pm->op_pmdynflags &= ~PMdf_USED;
5093 /* reset variables */
5095 if (!HvARRAY(stash))
5098 Zero(todo, 256, char);
5100 i = (unsigned char)*s;
5104 max = (unsigned char)*s++;
5105 for ( ; i <= max; i++) {
5108 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5109 for (entry = HvARRAY(stash)[i];
5111 entry = HeNEXT(entry))
5113 if (!todo[(U8)*HeKEY(entry)])
5115 gv = (GV*)HeVAL(entry);
5117 if (SvTHINKFIRST(sv)) {
5118 if (!SvREADONLY(sv) && SvROK(sv))
5123 if (SvTYPE(sv) >= SVt_PV) {
5125 if (SvPVX(sv) != Nullch)
5132 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5134 #ifndef VMS /* VMS has no environ array */
5136 environ[0] = Nullch;
5145 Perl_sv_2io(pTHX_ SV *sv)
5151 switch (SvTYPE(sv)) {
5159 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5163 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5165 return sv_2io(SvRV(sv));
5166 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5172 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5179 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5186 return *gvp = Nullgv, Nullcv;
5187 switch (SvTYPE(sv)) {
5207 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5208 tryAMAGICunDEREF(to_cv);
5211 if (SvTYPE(sv) == SVt_PVCV) {
5220 Perl_croak(aTHX_ "Not a subroutine reference");
5225 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5231 if (lref && !GvCVu(gv)) {
5234 tmpsv = NEWSV(704,0);
5235 gv_efullname3(tmpsv, gv, Nullch);
5236 /* XXX this is probably not what they think they're getting.
5237 * It has the same effect as "sub name;", i.e. just a forward
5239 newSUB(start_subparse(FALSE, 0),
5240 newSVOP(OP_CONST, 0, tmpsv),
5245 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5254 Returns true if the SV has a true value by Perl's rules.
5260 Perl_sv_true(pTHX_ register SV *sv)
5267 if ((tXpv = (XPV*)SvANY(sv)) &&
5268 (tXpv->xpv_cur > 1 ||
5269 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5276 return SvIVX(sv) != 0;
5279 return SvNVX(sv) != 0.0;
5281 return sv_2bool(sv);
5287 Perl_sv_iv(pTHX_ register SV *sv)
5291 return (IV)SvUVX(sv);
5298 Perl_sv_uv(pTHX_ register SV *sv)
5303 return (UV)SvIVX(sv);
5309 Perl_sv_nv(pTHX_ register SV *sv)
5317 Perl_sv_pv(pTHX_ SV *sv)
5324 return sv_2pv(sv, &n_a);
5328 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5334 return sv_2pv(sv, lp);
5338 =for apidoc sv_pvn_force
5340 Get a sensible string out of the SV somehow.
5346 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5350 if (SvTHINKFIRST(sv) && !SvROK(sv))
5351 sv_force_normal(sv);
5357 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5359 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5360 PL_op_name[PL_op->op_type]);
5364 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5369 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5370 SvGROW(sv, len + 1);
5371 Move(s,SvPVX(sv),len,char);
5376 SvPOK_on(sv); /* validate pointer */
5378 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5379 PTR2UV(sv),SvPVX(sv)));
5386 Perl_sv_pvbyte(pTHX_ SV *sv)
5392 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5394 return sv_pvn(sv,lp);
5398 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5400 return sv_pvn_force(sv,lp);
5404 Perl_sv_pvutf8(pTHX_ SV *sv)
5406 sv_utf8_upgrade(sv);
5411 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5413 sv_utf8_upgrade(sv);
5414 return sv_pvn(sv,lp);
5418 =for apidoc sv_pvutf8n_force
5420 Get a sensible UTF8-encoded string out of the SV somehow. See
5427 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5429 sv_utf8_upgrade(sv);
5430 return sv_pvn_force(sv,lp);
5434 =for apidoc sv_reftype
5436 Returns a string describing what the SV is a reference to.
5442 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5444 if (ob && SvOBJECT(sv))
5445 return HvNAME(SvSTASH(sv));
5447 switch (SvTYPE(sv)) {
5461 case SVt_PVLV: return "LVALUE";
5462 case SVt_PVAV: return "ARRAY";
5463 case SVt_PVHV: return "HASH";
5464 case SVt_PVCV: return "CODE";
5465 case SVt_PVGV: return "GLOB";
5466 case SVt_PVFM: return "FORMAT";
5467 case SVt_PVIO: return "IO";
5468 default: return "UNKNOWN";
5474 =for apidoc sv_isobject
5476 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5477 object. If the SV is not an RV, or if the object is not blessed, then this
5484 Perl_sv_isobject(pTHX_ SV *sv)
5501 Returns a boolean indicating whether the SV is blessed into the specified
5502 class. This does not check for subtypes; use C<sv_derived_from> to verify
5503 an inheritance relationship.
5509 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5521 return strEQ(HvNAME(SvSTASH(sv)), name);
5527 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5528 it will be upgraded to one. If C<classname> is non-null then the new SV will
5529 be blessed in the specified package. The new SV is returned and its
5530 reference count is 1.
5536 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5543 SV_CHECK_THINKFIRST(rv);
5546 if (SvTYPE(rv) < SVt_RV)
5547 sv_upgrade(rv, SVt_RV);
5554 HV* stash = gv_stashpv(classname, TRUE);
5555 (void)sv_bless(rv, stash);
5561 =for apidoc sv_setref_pv
5563 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5564 argument will be upgraded to an RV. That RV will be modified to point to
5565 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5566 into the SV. The C<classname> argument indicates the package for the
5567 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5568 will be returned and will have a reference count of 1.
5570 Do not use with other Perl types such as HV, AV, SV, CV, because those
5571 objects will become corrupted by the pointer copy process.
5573 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5579 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5582 sv_setsv(rv, &PL_sv_undef);
5586 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5591 =for apidoc sv_setref_iv
5593 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5594 argument will be upgraded to an RV. That RV will be modified to point to
5595 the new SV. The C<classname> argument indicates the package for the
5596 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5597 will be returned and will have a reference count of 1.
5603 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5605 sv_setiv(newSVrv(rv,classname), iv);
5610 =for apidoc sv_setref_nv
5612 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5613 argument will be upgraded to an RV. That RV will be modified to point to
5614 the new SV. The C<classname> argument indicates the package for the
5615 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5616 will be returned and will have a reference count of 1.
5622 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5624 sv_setnv(newSVrv(rv,classname), nv);
5629 =for apidoc sv_setref_pvn
5631 Copies a string into a new SV, optionally blessing the SV. The length of the
5632 string must be specified with C<n>. The C<rv> argument will be upgraded to
5633 an RV. That RV will be modified to point to the new SV. The C<classname>
5634 argument indicates the package for the blessing. Set C<classname> to
5635 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5636 a reference count of 1.
5638 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5644 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5646 sv_setpvn(newSVrv(rv,classname), pv, n);
5651 =for apidoc sv_bless
5653 Blesses an SV into a specified package. The SV must be an RV. The package
5654 must be designated by its stash (see C<gv_stashpv()>). The reference count
5655 of the SV is unaffected.
5661 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5666 Perl_croak(aTHX_ "Can't bless non-reference value");
5668 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5669 if (SvREADONLY(tmpRef))
5670 Perl_croak(aTHX_ PL_no_modify);
5671 if (SvOBJECT(tmpRef)) {
5672 if (SvTYPE(tmpRef) != SVt_PVIO)
5674 SvREFCNT_dec(SvSTASH(tmpRef));
5677 SvOBJECT_on(tmpRef);
5678 if (SvTYPE(tmpRef) != SVt_PVIO)
5680 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5681 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5692 S_sv_unglob(pTHX_ SV *sv)
5696 assert(SvTYPE(sv) == SVt_PVGV);
5701 SvREFCNT_dec(GvSTASH(sv));
5702 GvSTASH(sv) = Nullhv;
5704 sv_unmagic(sv, '*');
5705 Safefree(GvNAME(sv));
5708 /* need to keep SvANY(sv) in the right arena */
5709 xpvmg = new_XPVMG();
5710 StructCopy(SvANY(sv), xpvmg, XPVMG);
5711 del_XPVGV(SvANY(sv));
5714 SvFLAGS(sv) &= ~SVTYPEMASK;
5715 SvFLAGS(sv) |= SVt_PVMG;
5719 =for apidoc sv_unref
5721 Unsets the RV status of the SV, and decrements the reference count of
5722 whatever was being referenced by the RV. This can almost be thought of
5723 as a reversal of C<newSVrv>. See C<SvROK_off>.
5729 Perl_sv_unref(pTHX_ SV *sv)
5733 if (SvWEAKREF(sv)) {
5741 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5744 sv_2mortal(rv); /* Schedule for freeing later */
5748 Perl_sv_taint(pTHX_ SV *sv)
5750 sv_magic((sv), Nullsv, 't', Nullch, 0);
5754 Perl_sv_untaint(pTHX_ SV *sv)
5756 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5757 MAGIC *mg = mg_find(sv, 't');
5764 Perl_sv_tainted(pTHX_ SV *sv)
5766 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5767 MAGIC *mg = mg_find(sv, 't');
5768 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5775 =for apidoc sv_setpviv
5777 Copies an integer into the given SV, also updating its string value.
5778 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5784 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5786 char buf[TYPE_CHARS(UV)];
5788 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5790 sv_setpvn(sv, ptr, ebuf - ptr);
5795 =for apidoc sv_setpviv_mg
5797 Like C<sv_setpviv>, but also handles 'set' magic.
5803 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5805 char buf[TYPE_CHARS(UV)];
5807 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5809 sv_setpvn(sv, ptr, ebuf - ptr);
5813 #if defined(PERL_IMPLICIT_CONTEXT)
5815 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5819 va_start(args, pat);
5820 sv_vsetpvf(sv, pat, &args);
5826 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5830 va_start(args, pat);
5831 sv_vsetpvf_mg(sv, pat, &args);
5837 =for apidoc sv_setpvf
5839 Processes its arguments like C<sprintf> and sets an SV to the formatted
5840 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5846 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5849 va_start(args, pat);
5850 sv_vsetpvf(sv, pat, &args);
5855 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5857 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5861 =for apidoc sv_setpvf_mg
5863 Like C<sv_setpvf>, but also handles 'set' magic.
5869 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5872 va_start(args, pat);
5873 sv_vsetpvf_mg(sv, pat, &args);
5878 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5880 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5884 #if defined(PERL_IMPLICIT_CONTEXT)
5886 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5890 va_start(args, pat);
5891 sv_vcatpvf(sv, pat, &args);
5896 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5900 va_start(args, pat);
5901 sv_vcatpvf_mg(sv, pat, &args);
5907 =for apidoc sv_catpvf
5909 Processes its arguments like C<sprintf> and appends the formatted output
5910 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5911 typically be called after calling this function to handle 'set' magic.
5917 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5920 va_start(args, pat);
5921 sv_vcatpvf(sv, pat, &args);
5926 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5928 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5932 =for apidoc sv_catpvf_mg
5934 Like C<sv_catpvf>, but also handles 'set' magic.
5940 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5943 va_start(args, pat);
5944 sv_vcatpvf_mg(sv, pat, &args);
5949 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5951 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5956 =for apidoc sv_vsetpvfn
5958 Works like C<vcatpvfn> but copies the text into the SV instead of
5965 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5967 sv_setpvn(sv, "", 0);
5968 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5972 =for apidoc sv_vcatpvfn
5974 Processes its arguments like C<vsprintf> and appends the formatted output
5975 to an SV. Uses an array of SVs if the C style variable argument list is
5976 missing (NULL). When running with taint checks enabled, indicates via
5977 C<maybe_tainted> if results are untrustworthy (often due to the use of
5984 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5992 static char nullstr[] = "(null)";
5995 /* no matter what, this is a string now */
5996 (void)SvPV_force(sv, origlen);
5998 /* special-case "", "%s", and "%_" */
6001 if (patlen == 2 && pat[0] == '%') {
6005 char *s = va_arg(*args, char*);
6006 sv_catpv(sv, s ? s : nullstr);
6008 else if (svix < svmax) {
6009 sv_catsv(sv, *svargs);
6010 if (DO_UTF8(*svargs))
6016 argsv = va_arg(*args, SV*);
6017 sv_catsv(sv, argsv);
6022 /* See comment on '_' below */
6027 patend = (char*)pat + patlen;
6028 for (p = (char*)pat; p < patend; p = q) {
6031 bool vectorize = FALSE;
6038 bool has_precis = FALSE;
6040 bool is_utf = FALSE;
6043 U8 utf8buf[UTF8_MAXLEN];
6044 STRLEN esignlen = 0;
6046 char *eptr = Nullch;
6048 /* Times 4: a decimal digit takes more than 3 binary digits.
6049 * NV_DIG: mantissa takes than many decimal digits.
6050 * Plus 32: Playing safe. */
6051 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6052 /* large enough for "%#.#f" --chip */
6053 /* what about long double NVs? --jhi */
6056 U8 *vecstr = Null(U8*);
6068 STRLEN dotstrlen = 1;
6070 for (q = p; q < patend && *q != '%'; ++q) ;
6072 sv_catpvn(sv, p, q - p);
6101 case '*': /* printf("%*vX",":",$ipv6addr) */
6106 vecsv = va_arg(*args, SV*);
6107 else if (svix < svmax)
6108 vecsv = svargs[svix++];
6111 dotstr = SvPVx(vecsv,dotstrlen);
6130 case '1': case '2': case '3':
6131 case '4': case '5': case '6':
6132 case '7': case '8': case '9':
6135 width = width * 10 + (*q++ - '0');
6140 i = va_arg(*args, int);
6142 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6144 width = (i < 0) ? -i : i;
6155 i = va_arg(*args, int);
6157 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6158 precis = (i < 0) ? 0 : i;
6164 precis = precis * 10 + (*q++ - '0');
6171 vecsv = va_arg(*args, SV*);
6172 vecstr = (U8*)SvPVx(vecsv,veclen);
6173 utf = DO_UTF8(vecsv);
6175 else if (svix < svmax) {
6176 vecsv = svargs[svix++];
6177 vecstr = (U8*)SvPVx(vecsv,veclen);
6178 utf = DO_UTF8(vecsv);
6198 if (*(q + 1) == 'l') { /* lld */
6225 uv = va_arg(*args, int);
6227 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6228 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6229 eptr = (char*)utf8buf;
6230 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6242 eptr = va_arg(*args, char*);
6244 #ifdef MACOS_TRADITIONAL
6245 /* On MacOS, %#s format is used for Pascal strings */
6250 elen = strlen(eptr);
6253 elen = sizeof nullstr - 1;
6256 else if (svix < svmax) {
6257 argsv = svargs[svix++];
6258 eptr = SvPVx(argsv, elen);
6259 if (DO_UTF8(argsv)) {
6260 if (has_precis && precis < elen) {
6262 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6265 if (width) { /* fudge width (can't fudge elen) */
6266 width += elen - sv_len_utf8(argsv);
6275 * The "%_" hack might have to be changed someday,
6276 * if ISO or ANSI decide to use '_' for something.
6277 * So we keep it hidden from users' code.
6281 argsv = va_arg(*args,SV*);
6282 eptr = SvPVx(argsv, elen);
6288 if (has_precis && elen > precis)
6298 uv = PTR2UV(va_arg(*args, void*));
6300 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6320 iv = (IV)utf8_to_uv(vecstr, &ulen);
6330 case 'h': iv = (short)va_arg(*args, int); break;
6331 default: iv = va_arg(*args, int); break;
6332 case 'l': iv = va_arg(*args, long); break;
6333 case 'V': iv = va_arg(*args, IV); break;
6335 case 'q': iv = va_arg(*args, Quad_t); break;
6340 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6342 case 'h': iv = (short)iv; break;
6344 case 'l': iv = (long)iv; break;
6347 case 'q': iv = (Quad_t)iv; break;
6354 esignbuf[esignlen++] = plus;
6358 esignbuf[esignlen++] = '-';
6402 uv = utf8_to_uv(vecstr, &ulen);
6412 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6413 default: uv = va_arg(*args, unsigned); break;
6414 case 'l': uv = va_arg(*args, unsigned long); break;
6415 case 'V': uv = va_arg(*args, UV); break;
6417 case 'q': uv = va_arg(*args, Quad_t); break;
6422 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6424 case 'h': uv = (unsigned short)uv; break;
6426 case 'l': uv = (unsigned long)uv; break;
6429 case 'q': uv = (Quad_t)uv; break;
6435 eptr = ebuf + sizeof ebuf;
6441 p = (char*)((c == 'X')
6442 ? "0123456789ABCDEF" : "0123456789abcdef");
6448 esignbuf[esignlen++] = '0';
6449 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6455 *--eptr = '0' + dig;
6457 if (alt && *eptr != '0')
6463 *--eptr = '0' + dig;
6466 esignbuf[esignlen++] = '0';
6467 esignbuf[esignlen++] = 'b';
6470 default: /* it had better be ten or less */
6471 #if defined(PERL_Y2KWARN)
6472 if (ckWARN(WARN_Y2K)) {
6474 char *s = SvPV(sv,n);
6475 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6476 && (n == 2 || !isDIGIT(s[n-3])))
6478 Perl_warner(aTHX_ WARN_Y2K,
6479 "Possible Y2K bug: %%%c %s",
6480 c, "format string following '19'");
6486 *--eptr = '0' + dig;
6487 } while (uv /= base);
6490 elen = (ebuf + sizeof ebuf) - eptr;
6493 zeros = precis - elen;
6494 else if (precis == 0 && elen == 1 && *eptr == '0')
6499 /* FLOATING POINT */
6502 c = 'f'; /* maybe %F isn't supported here */
6508 /* This is evil, but floating point is even more evil */
6512 nv = va_arg(*args, NV);
6514 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6517 if (c != 'e' && c != 'E') {
6519 (void)Perl_frexp(nv, &i);
6520 if (i == PERL_INT_MIN)
6521 Perl_die(aTHX_ "panic: frexp");
6523 need = BIT_DIGITS(i);
6525 need += has_precis ? precis : 6; /* known default */
6529 need += 20; /* fudge factor */
6530 if (PL_efloatsize < need) {
6531 Safefree(PL_efloatbuf);
6532 PL_efloatsize = need + 20; /* more fudge */
6533 New(906, PL_efloatbuf, PL_efloatsize, char);
6534 PL_efloatbuf[0] = '\0';
6537 eptr = ebuf + sizeof ebuf;
6540 #ifdef USE_LONG_DOUBLE
6542 static char const my_prifldbl[] = PERL_PRIfldbl;
6543 char const *p = my_prifldbl + sizeof my_prifldbl - 3;
6544 while (p >= my_prifldbl) { *--eptr = *p--; }
6549 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6554 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6566 (void)sprintf(PL_efloatbuf, eptr, nv);
6568 eptr = PL_efloatbuf;
6569 elen = strlen(PL_efloatbuf);
6576 i = SvCUR(sv) - origlen;
6579 case 'h': *(va_arg(*args, short*)) = i; break;
6580 default: *(va_arg(*args, int*)) = i; break;
6581 case 'l': *(va_arg(*args, long*)) = i; break;
6582 case 'V': *(va_arg(*args, IV*)) = i; break;
6584 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6588 else if (svix < svmax)
6589 sv_setuv_mg(svargs[svix++], (UV)i);
6590 continue; /* not "break" */
6597 if (!args && ckWARN(WARN_PRINTF) &&
6598 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6599 SV *msg = sv_newmortal();
6600 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6601 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6604 Perl_sv_catpvf(aTHX_ msg,
6605 "\"%%%c\"", c & 0xFF);
6607 Perl_sv_catpvf(aTHX_ msg,
6608 "\"%%\\%03"UVof"\"",
6611 sv_catpv(msg, "end of string");
6612 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6615 /* output mangled stuff ... */
6621 /* ... right here, because formatting flags should not apply */
6622 SvGROW(sv, SvCUR(sv) + elen + 1);
6624 memcpy(p, eptr, elen);
6627 SvCUR(sv) = p - SvPVX(sv);
6628 continue; /* not "break" */
6631 have = esignlen + zeros + elen;
6632 need = (have > width ? have : width);
6635 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6637 if (esignlen && fill == '0') {
6638 for (i = 0; i < esignlen; i++)
6642 memset(p, fill, gap);
6645 if (esignlen && fill != '0') {
6646 for (i = 0; i < esignlen; i++)
6650 for (i = zeros; i; i--)
6654 memcpy(p, eptr, elen);
6658 memset(p, ' ', gap);
6663 memcpy(p, dotstr, dotstrlen);
6667 vectorize = FALSE; /* done iterating over vecstr */
6672 SvCUR(sv) = p - SvPVX(sv);
6680 #if defined(USE_ITHREADS)
6682 #if defined(USE_THREADS)
6683 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6686 #ifndef GpREFCNT_inc
6687 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6691 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6692 #define av_dup(s) (AV*)sv_dup((SV*)s)
6693 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6694 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6695 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6696 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6697 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6698 #define io_dup(s) (IO*)sv_dup((SV*)s)
6699 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6700 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6701 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6702 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6703 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6706 Perl_re_dup(pTHX_ REGEXP *r)
6708 /* XXX fix when pmop->op_pmregexp becomes shared */
6709 return ReREFCNT_inc(r);
6713 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6717 return (PerlIO*)NULL;
6719 /* look for it in the table first */
6720 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6724 /* create anew and remember what it is */
6725 ret = PerlIO_fdupopen(fp);
6726 ptr_table_store(PL_ptr_table, fp, ret);
6731 Perl_dirp_dup(pTHX_ DIR *dp)
6740 Perl_gp_dup(pTHX_ GP *gp)
6745 /* look for it in the table first */
6746 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6750 /* create anew and remember what it is */
6751 Newz(0, ret, 1, GP);
6752 ptr_table_store(PL_ptr_table, gp, ret);
6755 ret->gp_refcnt = 0; /* must be before any other dups! */
6756 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6757 ret->gp_io = io_dup_inc(gp->gp_io);
6758 ret->gp_form = cv_dup_inc(gp->gp_form);
6759 ret->gp_av = av_dup_inc(gp->gp_av);
6760 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6761 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6762 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6763 ret->gp_cvgen = gp->gp_cvgen;
6764 ret->gp_flags = gp->gp_flags;
6765 ret->gp_line = gp->gp_line;
6766 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6771 Perl_mg_dup(pTHX_ MAGIC *mg)
6773 MAGIC *mgret = (MAGIC*)NULL;
6776 return (MAGIC*)NULL;
6777 /* look for it in the table first */
6778 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6782 for (; mg; mg = mg->mg_moremagic) {
6784 Newz(0, nmg, 1, MAGIC);
6788 mgprev->mg_moremagic = nmg;
6789 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6790 nmg->mg_private = mg->mg_private;
6791 nmg->mg_type = mg->mg_type;
6792 nmg->mg_flags = mg->mg_flags;
6793 if (mg->mg_type == 'r') {
6794 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6797 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6798 ? sv_dup_inc(mg->mg_obj)
6799 : sv_dup(mg->mg_obj);
6801 nmg->mg_len = mg->mg_len;
6802 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6803 if (mg->mg_ptr && mg->mg_type != 'g') {
6804 if (mg->mg_len >= 0) {
6805 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6806 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6807 AMT *amtp = (AMT*)mg->mg_ptr;
6808 AMT *namtp = (AMT*)nmg->mg_ptr;
6810 for (i = 1; i < NofAMmeth; i++) {
6811 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6815 else if (mg->mg_len == HEf_SVKEY)
6816 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6824 Perl_ptr_table_new(pTHX)
6827 Newz(0, tbl, 1, PTR_TBL_t);
6830 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6835 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6837 PTR_TBL_ENT_t *tblent;
6838 UV hash = PTR2UV(sv);
6840 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6841 for (; tblent; tblent = tblent->next) {
6842 if (tblent->oldval == sv)
6843 return tblent->newval;
6849 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6851 PTR_TBL_ENT_t *tblent, **otblent;
6852 /* XXX this may be pessimal on platforms where pointers aren't good
6853 * hash values e.g. if they grow faster in the most significant
6855 UV hash = PTR2UV(oldv);
6859 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6860 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6861 if (tblent->oldval == oldv) {
6862 tblent->newval = newv;
6867 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6868 tblent->oldval = oldv;
6869 tblent->newval = newv;
6870 tblent->next = *otblent;
6873 if (i && tbl->tbl_items > tbl->tbl_max)
6874 ptr_table_split(tbl);
6878 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6880 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6881 UV oldsize = tbl->tbl_max + 1;
6882 UV newsize = oldsize * 2;
6885 Renew(ary, newsize, PTR_TBL_ENT_t*);
6886 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6887 tbl->tbl_max = --newsize;
6889 for (i=0; i < oldsize; i++, ary++) {
6890 PTR_TBL_ENT_t **curentp, **entp, *ent;
6893 curentp = ary + oldsize;
6894 for (entp = ary, ent = *ary; ent; ent = *entp) {
6895 if ((newsize & PTR2UV(ent->oldval)) != i) {
6897 ent->next = *curentp;
6912 Perl_sv_dup(pTHX_ SV *sstr)
6916 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6918 /* look for it in the table first */
6919 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6923 /* create anew and remember what it is */
6925 ptr_table_store(PL_ptr_table, sstr, dstr);
6928 SvFLAGS(dstr) = SvFLAGS(sstr);
6929 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6930 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6933 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6934 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6935 PL_watch_pvx, SvPVX(sstr));
6938 switch (SvTYPE(sstr)) {
6943 SvANY(dstr) = new_XIV();
6944 SvIVX(dstr) = SvIVX(sstr);
6947 SvANY(dstr) = new_XNV();
6948 SvNVX(dstr) = SvNVX(sstr);
6951 SvANY(dstr) = new_XRV();
6952 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6955 SvANY(dstr) = new_XPV();
6956 SvCUR(dstr) = SvCUR(sstr);
6957 SvLEN(dstr) = SvLEN(sstr);
6959 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6960 else if (SvPVX(sstr) && SvLEN(sstr))
6961 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6963 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6966 SvANY(dstr) = new_XPVIV();
6967 SvCUR(dstr) = SvCUR(sstr);
6968 SvLEN(dstr) = SvLEN(sstr);
6969 SvIVX(dstr) = SvIVX(sstr);
6971 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6972 else if (SvPVX(sstr) && SvLEN(sstr))
6973 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6975 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6978 SvANY(dstr) = new_XPVNV();
6979 SvCUR(dstr) = SvCUR(sstr);
6980 SvLEN(dstr) = SvLEN(sstr);
6981 SvIVX(dstr) = SvIVX(sstr);
6982 SvNVX(dstr) = SvNVX(sstr);
6984 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6985 else if (SvPVX(sstr) && SvLEN(sstr))
6986 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6988 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6991 SvANY(dstr) = new_XPVMG();
6992 SvCUR(dstr) = SvCUR(sstr);
6993 SvLEN(dstr) = SvLEN(sstr);
6994 SvIVX(dstr) = SvIVX(sstr);
6995 SvNVX(dstr) = SvNVX(sstr);
6996 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
6997 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
6999 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7000 else if (SvPVX(sstr) && SvLEN(sstr))
7001 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7003 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7006 SvANY(dstr) = new_XPVBM();
7007 SvCUR(dstr) = SvCUR(sstr);
7008 SvLEN(dstr) = SvLEN(sstr);
7009 SvIVX(dstr) = SvIVX(sstr);
7010 SvNVX(dstr) = SvNVX(sstr);
7011 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7012 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7014 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7015 else if (SvPVX(sstr) && SvLEN(sstr))
7016 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7018 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7019 BmRARE(dstr) = BmRARE(sstr);
7020 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7021 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7024 SvANY(dstr) = new_XPVLV();
7025 SvCUR(dstr) = SvCUR(sstr);
7026 SvLEN(dstr) = SvLEN(sstr);
7027 SvIVX(dstr) = SvIVX(sstr);
7028 SvNVX(dstr) = SvNVX(sstr);
7029 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7030 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7032 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7033 else if (SvPVX(sstr) && SvLEN(sstr))
7034 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7036 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7037 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7038 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7039 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7040 LvTYPE(dstr) = LvTYPE(sstr);
7043 SvANY(dstr) = new_XPVGV();
7044 SvCUR(dstr) = SvCUR(sstr);
7045 SvLEN(dstr) = SvLEN(sstr);
7046 SvIVX(dstr) = SvIVX(sstr);
7047 SvNVX(dstr) = SvNVX(sstr);
7048 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7049 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7051 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7052 else if (SvPVX(sstr) && SvLEN(sstr))
7053 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7055 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7056 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7057 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7058 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7059 GvFLAGS(dstr) = GvFLAGS(sstr);
7060 GvGP(dstr) = gp_dup(GvGP(sstr));
7061 (void)GpREFCNT_inc(GvGP(dstr));
7064 SvANY(dstr) = new_XPVIO();
7065 SvCUR(dstr) = SvCUR(sstr);
7066 SvLEN(dstr) = SvLEN(sstr);
7067 SvIVX(dstr) = SvIVX(sstr);
7068 SvNVX(dstr) = SvNVX(sstr);
7069 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7070 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7072 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7073 else if (SvPVX(sstr) && SvLEN(sstr))
7074 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7076 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7077 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7078 if (IoOFP(sstr) == IoIFP(sstr))
7079 IoOFP(dstr) = IoIFP(dstr);
7081 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7082 /* PL_rsfp_filters entries have fake IoDIRP() */
7083 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7084 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7086 IoDIRP(dstr) = IoDIRP(sstr);
7087 IoLINES(dstr) = IoLINES(sstr);
7088 IoPAGE(dstr) = IoPAGE(sstr);
7089 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7090 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7091 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7092 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7093 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7094 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7095 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7096 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7097 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7098 IoTYPE(dstr) = IoTYPE(sstr);
7099 IoFLAGS(dstr) = IoFLAGS(sstr);
7102 SvANY(dstr) = new_XPVAV();
7103 SvCUR(dstr) = SvCUR(sstr);
7104 SvLEN(dstr) = SvLEN(sstr);
7105 SvIVX(dstr) = SvIVX(sstr);
7106 SvNVX(dstr) = SvNVX(sstr);
7107 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7108 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7109 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7110 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7111 if (AvARRAY((AV*)sstr)) {
7112 SV **dst_ary, **src_ary;
7113 SSize_t items = AvFILLp((AV*)sstr) + 1;
7115 src_ary = AvARRAY((AV*)sstr);
7116 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7117 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7118 SvPVX(dstr) = (char*)dst_ary;
7119 AvALLOC((AV*)dstr) = dst_ary;
7120 if (AvREAL((AV*)sstr)) {
7122 *dst_ary++ = sv_dup_inc(*src_ary++);
7126 *dst_ary++ = sv_dup(*src_ary++);
7128 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7129 while (items-- > 0) {
7130 *dst_ary++ = &PL_sv_undef;
7134 SvPVX(dstr) = Nullch;
7135 AvALLOC((AV*)dstr) = (SV**)NULL;
7139 SvANY(dstr) = new_XPVHV();
7140 SvCUR(dstr) = SvCUR(sstr);
7141 SvLEN(dstr) = SvLEN(sstr);
7142 SvIVX(dstr) = SvIVX(sstr);
7143 SvNVX(dstr) = SvNVX(sstr);
7144 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7145 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7146 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7147 if (HvARRAY((HV*)sstr)) {
7149 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7150 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7151 Newz(0, dxhv->xhv_array,
7152 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7153 while (i <= sxhv->xhv_max) {
7154 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7155 !!HvSHAREKEYS(sstr));
7158 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7161 SvPVX(dstr) = Nullch;
7162 HvEITER((HV*)dstr) = (HE*)NULL;
7164 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7165 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7168 SvANY(dstr) = new_XPVFM();
7169 FmLINES(dstr) = FmLINES(sstr);
7173 SvANY(dstr) = new_XPVCV();
7175 SvCUR(dstr) = SvCUR(sstr);
7176 SvLEN(dstr) = SvLEN(sstr);
7177 SvIVX(dstr) = SvIVX(sstr);
7178 SvNVX(dstr) = SvNVX(sstr);
7179 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7180 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7181 if (SvPVX(sstr) && SvLEN(sstr))
7182 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7184 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7185 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7186 CvSTART(dstr) = CvSTART(sstr);
7187 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7188 CvXSUB(dstr) = CvXSUB(sstr);
7189 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7190 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7191 CvDEPTH(dstr) = CvDEPTH(sstr);
7192 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7193 /* XXX padlists are real, but pretend to be not */
7194 AvREAL_on(CvPADLIST(sstr));
7195 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7196 AvREAL_off(CvPADLIST(sstr));
7197 AvREAL_off(CvPADLIST(dstr));
7200 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7201 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7202 CvFLAGS(dstr) = CvFLAGS(sstr);
7205 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7209 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7216 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7221 return (PERL_CONTEXT*)NULL;
7223 /* look for it in the table first */
7224 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7228 /* create anew and remember what it is */
7229 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7230 ptr_table_store(PL_ptr_table, cxs, ncxs);
7233 PERL_CONTEXT *cx = &cxs[ix];
7234 PERL_CONTEXT *ncx = &ncxs[ix];
7235 ncx->cx_type = cx->cx_type;
7236 if (CxTYPE(cx) == CXt_SUBST) {
7237 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7240 ncx->blk_oldsp = cx->blk_oldsp;
7241 ncx->blk_oldcop = cx->blk_oldcop;
7242 ncx->blk_oldretsp = cx->blk_oldretsp;
7243 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7244 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7245 ncx->blk_oldpm = cx->blk_oldpm;
7246 ncx->blk_gimme = cx->blk_gimme;
7247 switch (CxTYPE(cx)) {
7249 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7250 ? cv_dup_inc(cx->blk_sub.cv)
7251 : cv_dup(cx->blk_sub.cv));
7252 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7253 ? av_dup_inc(cx->blk_sub.argarray)
7255 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7256 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7257 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7258 ncx->blk_sub.lval = cx->blk_sub.lval;
7261 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7262 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7263 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7264 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7265 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7268 ncx->blk_loop.label = cx->blk_loop.label;
7269 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7270 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7271 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7272 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7273 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7274 ? cx->blk_loop.iterdata
7275 : gv_dup((GV*)cx->blk_loop.iterdata));
7276 ncx->blk_loop.oldcurpad
7277 = (SV**)ptr_table_fetch(PL_ptr_table,
7278 cx->blk_loop.oldcurpad);
7279 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7280 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7281 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7282 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7283 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7286 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7287 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7288 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7289 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7302 Perl_si_dup(pTHX_ PERL_SI *si)
7307 return (PERL_SI*)NULL;
7309 /* look for it in the table first */
7310 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7314 /* create anew and remember what it is */
7315 Newz(56, nsi, 1, PERL_SI);
7316 ptr_table_store(PL_ptr_table, si, nsi);
7318 nsi->si_stack = av_dup_inc(si->si_stack);
7319 nsi->si_cxix = si->si_cxix;
7320 nsi->si_cxmax = si->si_cxmax;
7321 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7322 nsi->si_type = si->si_type;
7323 nsi->si_prev = si_dup(si->si_prev);
7324 nsi->si_next = si_dup(si->si_next);
7325 nsi->si_markoff = si->si_markoff;
7330 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7331 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7332 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7333 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7334 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7335 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7336 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7337 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7338 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7339 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7340 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7341 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7344 #define pv_dup_inc(p) SAVEPV(p)
7345 #define pv_dup(p) SAVEPV(p)
7346 #define svp_dup_inc(p,pp) any_dup(p,pp)
7349 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7356 /* look for it in the table first */
7357 ret = ptr_table_fetch(PL_ptr_table, v);
7361 /* see if it is part of the interpreter structure */
7362 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7363 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7371 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7373 ANY *ss = proto_perl->Tsavestack;
7374 I32 ix = proto_perl->Tsavestack_ix;
7375 I32 max = proto_perl->Tsavestack_max;
7388 void (*dptr) (void*);
7389 void (*dxptr) (pTHXo_ void*);
7392 Newz(54, nss, max, ANY);
7398 case SAVEt_ITEM: /* normal string */
7399 sv = (SV*)POPPTR(ss,ix);
7400 TOPPTR(nss,ix) = sv_dup_inc(sv);
7401 sv = (SV*)POPPTR(ss,ix);
7402 TOPPTR(nss,ix) = sv_dup_inc(sv);
7404 case SAVEt_SV: /* scalar reference */
7405 sv = (SV*)POPPTR(ss,ix);
7406 TOPPTR(nss,ix) = sv_dup_inc(sv);
7407 gv = (GV*)POPPTR(ss,ix);
7408 TOPPTR(nss,ix) = gv_dup_inc(gv);
7410 case SAVEt_GENERIC_PVREF: /* generic char* */
7411 c = (char*)POPPTR(ss,ix);
7412 TOPPTR(nss,ix) = pv_dup(c);
7413 ptr = POPPTR(ss,ix);
7414 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7416 case SAVEt_GENERIC_SVREF: /* generic sv */
7417 case SAVEt_SVREF: /* scalar reference */
7418 sv = (SV*)POPPTR(ss,ix);
7419 TOPPTR(nss,ix) = sv_dup_inc(sv);
7420 ptr = POPPTR(ss,ix);
7421 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7423 case SAVEt_AV: /* array reference */
7424 av = (AV*)POPPTR(ss,ix);
7425 TOPPTR(nss,ix) = av_dup_inc(av);
7426 gv = (GV*)POPPTR(ss,ix);
7427 TOPPTR(nss,ix) = gv_dup(gv);
7429 case SAVEt_HV: /* hash reference */
7430 hv = (HV*)POPPTR(ss,ix);
7431 TOPPTR(nss,ix) = hv_dup_inc(hv);
7432 gv = (GV*)POPPTR(ss,ix);
7433 TOPPTR(nss,ix) = gv_dup(gv);
7435 case SAVEt_INT: /* int reference */
7436 ptr = POPPTR(ss,ix);
7437 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7438 intval = (int)POPINT(ss,ix);
7439 TOPINT(nss,ix) = intval;
7441 case SAVEt_LONG: /* long reference */
7442 ptr = POPPTR(ss,ix);
7443 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7444 longval = (long)POPLONG(ss,ix);
7445 TOPLONG(nss,ix) = longval;
7447 case SAVEt_I32: /* I32 reference */
7448 case SAVEt_I16: /* I16 reference */
7449 case SAVEt_I8: /* I8 reference */
7450 ptr = POPPTR(ss,ix);
7451 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7455 case SAVEt_IV: /* IV reference */
7456 ptr = POPPTR(ss,ix);
7457 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7461 case SAVEt_SPTR: /* SV* reference */
7462 ptr = POPPTR(ss,ix);
7463 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7464 sv = (SV*)POPPTR(ss,ix);
7465 TOPPTR(nss,ix) = sv_dup(sv);
7467 case SAVEt_VPTR: /* random* reference */
7468 ptr = POPPTR(ss,ix);
7469 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7470 ptr = POPPTR(ss,ix);
7471 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7473 case SAVEt_PPTR: /* char* reference */
7474 ptr = POPPTR(ss,ix);
7475 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7476 c = (char*)POPPTR(ss,ix);
7477 TOPPTR(nss,ix) = pv_dup(c);
7479 case SAVEt_HPTR: /* HV* reference */
7480 ptr = POPPTR(ss,ix);
7481 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7482 hv = (HV*)POPPTR(ss,ix);
7483 TOPPTR(nss,ix) = hv_dup(hv);
7485 case SAVEt_APTR: /* AV* reference */
7486 ptr = POPPTR(ss,ix);
7487 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7488 av = (AV*)POPPTR(ss,ix);
7489 TOPPTR(nss,ix) = av_dup(av);
7492 gv = (GV*)POPPTR(ss,ix);
7493 TOPPTR(nss,ix) = gv_dup(gv);
7495 case SAVEt_GP: /* scalar reference */
7496 gp = (GP*)POPPTR(ss,ix);
7497 TOPPTR(nss,ix) = gp = gp_dup(gp);
7498 (void)GpREFCNT_inc(gp);
7499 gv = (GV*)POPPTR(ss,ix);
7500 TOPPTR(nss,ix) = gv_dup_inc(c);
7501 c = (char*)POPPTR(ss,ix);
7502 TOPPTR(nss,ix) = pv_dup(c);
7509 sv = (SV*)POPPTR(ss,ix);
7510 TOPPTR(nss,ix) = sv_dup_inc(sv);
7513 ptr = POPPTR(ss,ix);
7514 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7515 /* these are assumed to be refcounted properly */
7516 switch (((OP*)ptr)->op_type) {
7523 TOPPTR(nss,ix) = ptr;
7528 TOPPTR(nss,ix) = Nullop;
7533 TOPPTR(nss,ix) = Nullop;
7536 c = (char*)POPPTR(ss,ix);
7537 TOPPTR(nss,ix) = pv_dup_inc(c);
7540 longval = POPLONG(ss,ix);
7541 TOPLONG(nss,ix) = longval;
7544 hv = (HV*)POPPTR(ss,ix);
7545 TOPPTR(nss,ix) = hv_dup_inc(hv);
7546 c = (char*)POPPTR(ss,ix);
7547 TOPPTR(nss,ix) = pv_dup_inc(c);
7551 case SAVEt_DESTRUCTOR:
7552 ptr = POPPTR(ss,ix);
7553 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7554 dptr = POPDPTR(ss,ix);
7555 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7557 case SAVEt_DESTRUCTOR_X:
7558 ptr = POPPTR(ss,ix);
7559 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7560 dxptr = POPDXPTR(ss,ix);
7561 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7563 case SAVEt_REGCONTEXT:
7569 case SAVEt_STACK_POS: /* Position on Perl stack */
7573 case SAVEt_AELEM: /* array element */
7574 sv = (SV*)POPPTR(ss,ix);
7575 TOPPTR(nss,ix) = sv_dup_inc(sv);
7578 av = (AV*)POPPTR(ss,ix);
7579 TOPPTR(nss,ix) = av_dup_inc(av);
7581 case SAVEt_HELEM: /* hash element */
7582 sv = (SV*)POPPTR(ss,ix);
7583 TOPPTR(nss,ix) = sv_dup_inc(sv);
7584 sv = (SV*)POPPTR(ss,ix);
7585 TOPPTR(nss,ix) = sv_dup_inc(sv);
7586 hv = (HV*)POPPTR(ss,ix);
7587 TOPPTR(nss,ix) = hv_dup_inc(hv);
7590 ptr = POPPTR(ss,ix);
7591 TOPPTR(nss,ix) = ptr;
7598 av = (AV*)POPPTR(ss,ix);
7599 TOPPTR(nss,ix) = av_dup(av);
7602 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7614 perl_clone(PerlInterpreter *proto_perl, UV flags)
7617 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7620 #ifdef PERL_IMPLICIT_SYS
7621 return perl_clone_using(proto_perl, flags,
7623 proto_perl->IMemShared,
7624 proto_perl->IMemParse,
7634 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7635 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7636 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7637 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7638 struct IPerlDir* ipD, struct IPerlSock* ipS,
7639 struct IPerlProc* ipP)
7641 /* XXX many of the string copies here can be optimized if they're
7642 * constants; they need to be allocated as common memory and just
7643 * their pointers copied. */
7647 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7649 PERL_SET_THX(pPerl);
7650 # else /* !PERL_OBJECT */
7651 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7652 PERL_SET_THX(my_perl);
7655 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7660 # else /* !DEBUGGING */
7661 Zero(my_perl, 1, PerlInterpreter);
7662 # endif /* DEBUGGING */
7666 PL_MemShared = ipMS;
7674 # endif /* PERL_OBJECT */
7675 #else /* !PERL_IMPLICIT_SYS */
7677 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7678 PERL_SET_THX(my_perl);
7681 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7686 # else /* !DEBUGGING */
7687 Zero(my_perl, 1, PerlInterpreter);
7688 # endif /* DEBUGGING */
7689 #endif /* PERL_IMPLICIT_SYS */
7692 PL_xiv_arenaroot = NULL;
7694 PL_xnv_arenaroot = NULL;
7696 PL_xrv_arenaroot = NULL;
7698 PL_xpv_arenaroot = NULL;
7700 PL_xpviv_arenaroot = NULL;
7701 PL_xpviv_root = NULL;
7702 PL_xpvnv_arenaroot = NULL;
7703 PL_xpvnv_root = NULL;
7704 PL_xpvcv_arenaroot = NULL;
7705 PL_xpvcv_root = NULL;
7706 PL_xpvav_arenaroot = NULL;
7707 PL_xpvav_root = NULL;
7708 PL_xpvhv_arenaroot = NULL;
7709 PL_xpvhv_root = NULL;
7710 PL_xpvmg_arenaroot = NULL;
7711 PL_xpvmg_root = NULL;
7712 PL_xpvlv_arenaroot = NULL;
7713 PL_xpvlv_root = NULL;
7714 PL_xpvbm_arenaroot = NULL;
7715 PL_xpvbm_root = NULL;
7716 PL_he_arenaroot = NULL;
7718 PL_nice_chunk = NULL;
7719 PL_nice_chunk_size = 0;
7722 PL_sv_root = Nullsv;
7723 PL_sv_arenaroot = Nullsv;
7725 PL_debug = proto_perl->Idebug;
7727 /* create SV map for pointer relocation */
7728 PL_ptr_table = ptr_table_new();
7730 /* initialize these special pointers as early as possible */
7731 SvANY(&PL_sv_undef) = NULL;
7732 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7733 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7734 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7737 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7739 SvANY(&PL_sv_no) = new_XPVNV();
7741 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7742 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7743 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7744 SvCUR(&PL_sv_no) = 0;
7745 SvLEN(&PL_sv_no) = 1;
7746 SvNVX(&PL_sv_no) = 0;
7747 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7750 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7752 SvANY(&PL_sv_yes) = new_XPVNV();
7754 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7755 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7756 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7757 SvCUR(&PL_sv_yes) = 1;
7758 SvLEN(&PL_sv_yes) = 2;
7759 SvNVX(&PL_sv_yes) = 1;
7760 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7762 /* create shared string table */
7763 PL_strtab = newHV();
7764 HvSHAREKEYS_off(PL_strtab);
7765 hv_ksplit(PL_strtab, 512);
7766 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7768 PL_compiling = proto_perl->Icompiling;
7769 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7770 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7771 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7772 if (!specialWARN(PL_compiling.cop_warnings))
7773 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7774 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7776 /* pseudo environmental stuff */
7777 PL_origargc = proto_perl->Iorigargc;
7779 New(0, PL_origargv, i+1, char*);
7780 PL_origargv[i] = '\0';
7782 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7784 PL_envgv = gv_dup(proto_perl->Ienvgv);
7785 PL_incgv = gv_dup(proto_perl->Iincgv);
7786 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7787 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7788 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7789 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7792 PL_minus_c = proto_perl->Iminus_c;
7793 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7794 PL_localpatches = proto_perl->Ilocalpatches;
7795 PL_splitstr = proto_perl->Isplitstr;
7796 PL_preprocess = proto_perl->Ipreprocess;
7797 PL_minus_n = proto_perl->Iminus_n;
7798 PL_minus_p = proto_perl->Iminus_p;
7799 PL_minus_l = proto_perl->Iminus_l;
7800 PL_minus_a = proto_perl->Iminus_a;
7801 PL_minus_F = proto_perl->Iminus_F;
7802 PL_doswitches = proto_perl->Idoswitches;
7803 PL_dowarn = proto_perl->Idowarn;
7804 PL_doextract = proto_perl->Idoextract;
7805 PL_sawampersand = proto_perl->Isawampersand;
7806 PL_unsafe = proto_perl->Iunsafe;
7807 PL_inplace = SAVEPV(proto_perl->Iinplace);
7808 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7809 PL_perldb = proto_perl->Iperldb;
7810 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7812 /* magical thingies */
7813 /* XXX time(&PL_basetime) when asked for? */
7814 PL_basetime = proto_perl->Ibasetime;
7815 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7817 PL_maxsysfd = proto_perl->Imaxsysfd;
7818 PL_multiline = proto_perl->Imultiline;
7819 PL_statusvalue = proto_perl->Istatusvalue;
7821 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7824 /* shortcuts to various I/O objects */
7825 PL_stdingv = gv_dup(proto_perl->Istdingv);
7826 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7827 PL_defgv = gv_dup(proto_perl->Idefgv);
7828 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7829 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7830 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7832 /* shortcuts to regexp stuff */
7833 PL_replgv = gv_dup(proto_perl->Ireplgv);
7835 /* shortcuts to misc objects */
7836 PL_errgv = gv_dup(proto_perl->Ierrgv);
7838 /* shortcuts to debugging objects */
7839 PL_DBgv = gv_dup(proto_perl->IDBgv);
7840 PL_DBline = gv_dup(proto_perl->IDBline);
7841 PL_DBsub = gv_dup(proto_perl->IDBsub);
7842 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7843 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7844 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7845 PL_lineary = av_dup(proto_perl->Ilineary);
7846 PL_dbargs = av_dup(proto_perl->Idbargs);
7849 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7850 PL_curstash = hv_dup(proto_perl->Tcurstash);
7851 PL_debstash = hv_dup(proto_perl->Idebstash);
7852 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7853 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7855 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7856 PL_endav = av_dup_inc(proto_perl->Iendav);
7857 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7858 PL_initav = av_dup_inc(proto_perl->Iinitav);
7860 PL_sub_generation = proto_perl->Isub_generation;
7862 /* funky return mechanisms */
7863 PL_forkprocess = proto_perl->Iforkprocess;
7865 /* subprocess state */
7866 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7868 /* internal state */
7869 PL_tainting = proto_perl->Itainting;
7870 PL_maxo = proto_perl->Imaxo;
7871 if (proto_perl->Iop_mask)
7872 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7874 PL_op_mask = Nullch;
7876 /* current interpreter roots */
7877 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7878 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7879 PL_main_start = proto_perl->Imain_start;
7880 PL_eval_root = proto_perl->Ieval_root;
7881 PL_eval_start = proto_perl->Ieval_start;
7883 /* runtime control stuff */
7884 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7885 PL_copline = proto_perl->Icopline;
7887 PL_filemode = proto_perl->Ifilemode;
7888 PL_lastfd = proto_perl->Ilastfd;
7889 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7892 PL_gensym = proto_perl->Igensym;
7893 PL_preambled = proto_perl->Ipreambled;
7894 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7895 PL_laststatval = proto_perl->Ilaststatval;
7896 PL_laststype = proto_perl->Ilaststype;
7897 PL_mess_sv = Nullsv;
7899 PL_orslen = proto_perl->Iorslen;
7900 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7901 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7903 /* interpreter atexit processing */
7904 PL_exitlistlen = proto_perl->Iexitlistlen;
7905 if (PL_exitlistlen) {
7906 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7907 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7910 PL_exitlist = (PerlExitListEntry*)NULL;
7911 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7913 PL_profiledata = NULL;
7914 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7915 /* PL_rsfp_filters entries have fake IoDIRP() */
7916 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7918 PL_compcv = cv_dup(proto_perl->Icompcv);
7919 PL_comppad = av_dup(proto_perl->Icomppad);
7920 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7921 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7922 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7923 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7924 proto_perl->Tcurpad);
7926 #ifdef HAVE_INTERP_INTERN
7927 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7930 /* more statics moved here */
7931 PL_generation = proto_perl->Igeneration;
7932 PL_DBcv = cv_dup(proto_perl->IDBcv);
7934 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7935 PL_in_clean_all = proto_perl->Iin_clean_all;
7937 PL_uid = proto_perl->Iuid;
7938 PL_euid = proto_perl->Ieuid;
7939 PL_gid = proto_perl->Igid;
7940 PL_egid = proto_perl->Iegid;
7941 PL_nomemok = proto_perl->Inomemok;
7942 PL_an = proto_perl->Ian;
7943 PL_cop_seqmax = proto_perl->Icop_seqmax;
7944 PL_op_seqmax = proto_perl->Iop_seqmax;
7945 PL_evalseq = proto_perl->Ievalseq;
7946 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7947 PL_origalen = proto_perl->Iorigalen;
7948 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7949 PL_osname = SAVEPV(proto_perl->Iosname);
7950 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7951 PL_sighandlerp = proto_perl->Isighandlerp;
7954 PL_runops = proto_perl->Irunops;
7956 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7959 PL_cshlen = proto_perl->Icshlen;
7960 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7963 PL_lex_state = proto_perl->Ilex_state;
7964 PL_lex_defer = proto_perl->Ilex_defer;
7965 PL_lex_expect = proto_perl->Ilex_expect;
7966 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7967 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7968 PL_lex_starts = proto_perl->Ilex_starts;
7969 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7970 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7971 PL_lex_op = proto_perl->Ilex_op;
7972 PL_lex_inpat = proto_perl->Ilex_inpat;
7973 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7974 PL_lex_brackets = proto_perl->Ilex_brackets;
7975 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7976 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7977 PL_lex_casemods = proto_perl->Ilex_casemods;
7978 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7979 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7981 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7982 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
7983 PL_nexttoke = proto_perl->Inexttoke;
7985 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
7986 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
7987 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7988 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
7989 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7990 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
7991 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7992 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
7993 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
7994 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
7995 PL_pending_ident = proto_perl->Ipending_ident;
7996 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
7998 PL_expect = proto_perl->Iexpect;
8000 PL_multi_start = proto_perl->Imulti_start;
8001 PL_multi_end = proto_perl->Imulti_end;
8002 PL_multi_open = proto_perl->Imulti_open;
8003 PL_multi_close = proto_perl->Imulti_close;
8005 PL_error_count = proto_perl->Ierror_count;
8006 PL_subline = proto_perl->Isubline;
8007 PL_subname = sv_dup_inc(proto_perl->Isubname);
8009 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8010 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8011 PL_padix = proto_perl->Ipadix;
8012 PL_padix_floor = proto_perl->Ipadix_floor;
8013 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8015 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8016 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8017 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8018 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8019 PL_last_lop_op = proto_perl->Ilast_lop_op;
8020 PL_in_my = proto_perl->Iin_my;
8021 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8023 PL_cryptseen = proto_perl->Icryptseen;
8026 PL_hints = proto_perl->Ihints;
8028 PL_amagic_generation = proto_perl->Iamagic_generation;
8030 #ifdef USE_LOCALE_COLLATE
8031 PL_collation_ix = proto_perl->Icollation_ix;
8032 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8033 PL_collation_standard = proto_perl->Icollation_standard;
8034 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8035 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8036 #endif /* USE_LOCALE_COLLATE */
8038 #ifdef USE_LOCALE_NUMERIC
8039 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8040 PL_numeric_standard = proto_perl->Inumeric_standard;
8041 PL_numeric_local = proto_perl->Inumeric_local;
8042 PL_numeric_radix = proto_perl->Inumeric_radix;
8043 #endif /* !USE_LOCALE_NUMERIC */
8045 /* utf8 character classes */
8046 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8047 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8048 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8049 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8050 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8051 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8052 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8053 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8054 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8055 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8056 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8057 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8058 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8059 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8060 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8061 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8062 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8065 PL_last_swash_hv = Nullhv; /* reinits on demand */
8066 PL_last_swash_klen = 0;
8067 PL_last_swash_key[0]= '\0';
8068 PL_last_swash_tmps = (U8*)NULL;
8069 PL_last_swash_slen = 0;
8071 /* perly.c globals */
8072 PL_yydebug = proto_perl->Iyydebug;
8073 PL_yynerrs = proto_perl->Iyynerrs;
8074 PL_yyerrflag = proto_perl->Iyyerrflag;
8075 PL_yychar = proto_perl->Iyychar;
8076 PL_yyval = proto_perl->Iyyval;
8077 PL_yylval = proto_perl->Iyylval;
8079 PL_glob_index = proto_perl->Iglob_index;
8080 PL_srand_called = proto_perl->Isrand_called;
8081 PL_uudmap['M'] = 0; /* reinits on demand */
8082 PL_bitcount = Nullch; /* reinits on demand */
8084 if (proto_perl->Ipsig_ptr) {
8085 int sig_num[] = { SIG_NUM };
8086 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8087 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8088 for (i = 1; PL_sig_name[i]; i++) {
8089 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8090 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8094 PL_psig_ptr = (SV**)NULL;
8095 PL_psig_name = (SV**)NULL;
8098 /* thrdvar.h stuff */
8101 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8102 PL_tmps_ix = proto_perl->Ttmps_ix;
8103 PL_tmps_max = proto_perl->Ttmps_max;
8104 PL_tmps_floor = proto_perl->Ttmps_floor;
8105 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8107 while (i <= PL_tmps_ix) {
8108 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8112 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8113 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8114 Newz(54, PL_markstack, i, I32);
8115 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8116 - proto_perl->Tmarkstack);
8117 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8118 - proto_perl->Tmarkstack);
8119 Copy(proto_perl->Tmarkstack, PL_markstack,
8120 PL_markstack_ptr - PL_markstack + 1, I32);
8122 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8123 * NOTE: unlike the others! */
8124 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8125 PL_scopestack_max = proto_perl->Tscopestack_max;
8126 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8127 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8129 /* next push_return() sets PL_retstack[PL_retstack_ix]
8130 * NOTE: unlike the others! */
8131 PL_retstack_ix = proto_perl->Tretstack_ix;
8132 PL_retstack_max = proto_perl->Tretstack_max;
8133 Newz(54, PL_retstack, PL_retstack_max, OP*);
8134 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8136 /* NOTE: si_dup() looks at PL_markstack */
8137 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8139 /* PL_curstack = PL_curstackinfo->si_stack; */
8140 PL_curstack = av_dup(proto_perl->Tcurstack);
8141 PL_mainstack = av_dup(proto_perl->Tmainstack);
8143 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8144 PL_stack_base = AvARRAY(PL_curstack);
8145 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8146 - proto_perl->Tstack_base);
8147 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8149 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8150 * NOTE: unlike the others! */
8151 PL_savestack_ix = proto_perl->Tsavestack_ix;
8152 PL_savestack_max = proto_perl->Tsavestack_max;
8153 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8154 PL_savestack = ss_dup(proto_perl);
8158 ENTER; /* perl_destruct() wants to LEAVE; */
8161 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8162 PL_top_env = &PL_start_env;
8164 PL_op = proto_perl->Top;
8167 PL_Xpv = (XPV*)NULL;
8168 PL_na = proto_perl->Tna;
8170 PL_statbuf = proto_perl->Tstatbuf;
8171 PL_statcache = proto_perl->Tstatcache;
8172 PL_statgv = gv_dup(proto_perl->Tstatgv);
8173 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8175 PL_timesbuf = proto_perl->Ttimesbuf;
8178 PL_tainted = proto_perl->Ttainted;
8179 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8180 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8181 PL_rs = sv_dup_inc(proto_perl->Trs);
8182 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8183 PL_ofslen = proto_perl->Tofslen;
8184 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8185 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8186 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8187 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8188 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8189 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8191 PL_restartop = proto_perl->Trestartop;
8192 PL_in_eval = proto_perl->Tin_eval;
8193 PL_delaymagic = proto_perl->Tdelaymagic;
8194 PL_dirty = proto_perl->Tdirty;
8195 PL_localizing = proto_perl->Tlocalizing;
8197 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8198 PL_protect = proto_perl->Tprotect;
8200 PL_errors = sv_dup_inc(proto_perl->Terrors);
8201 PL_av_fetch_sv = Nullsv;
8202 PL_hv_fetch_sv = Nullsv;
8203 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8204 PL_modcount = proto_perl->Tmodcount;
8205 PL_lastgotoprobe = Nullop;
8206 PL_dumpindent = proto_perl->Tdumpindent;
8208 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8209 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8210 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8211 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8212 PL_sortcxix = proto_perl->Tsortcxix;
8213 PL_efloatbuf = Nullch; /* reinits on demand */
8214 PL_efloatsize = 0; /* reinits on demand */
8218 PL_screamfirst = NULL;
8219 PL_screamnext = NULL;
8220 PL_maxscream = -1; /* reinits on demand */
8221 PL_lastscream = Nullsv;
8223 PL_watchaddr = NULL;
8224 PL_watchok = Nullch;
8226 PL_regdummy = proto_perl->Tregdummy;
8227 PL_regcomp_parse = Nullch;
8228 PL_regxend = Nullch;
8229 PL_regcode = (regnode*)NULL;
8232 PL_regprecomp = Nullch;
8237 PL_seen_zerolen = 0;
8239 PL_regcomp_rx = (regexp*)NULL;
8241 PL_colorset = 0; /* reinits PL_colors[] */
8242 /*PL_colors[6] = {0,0,0,0,0,0};*/
8243 PL_reg_whilem_seen = 0;
8244 PL_reginput = Nullch;
8247 PL_regstartp = (I32*)NULL;
8248 PL_regendp = (I32*)NULL;
8249 PL_reglastparen = (U32*)NULL;
8250 PL_regtill = Nullch;
8252 PL_reg_start_tmp = (char**)NULL;
8253 PL_reg_start_tmpl = 0;
8254 PL_regdata = (struct reg_data*)NULL;
8257 PL_reg_eval_set = 0;
8259 PL_regprogram = (regnode*)NULL;
8261 PL_regcc = (CURCUR*)NULL;
8262 PL_reg_call_cc = (struct re_cc_state*)NULL;
8263 PL_reg_re = (regexp*)NULL;
8264 PL_reg_ganch = Nullch;
8266 PL_reg_magic = (MAGIC*)NULL;
8268 PL_reg_oldcurpm = (PMOP*)NULL;
8269 PL_reg_curpm = (PMOP*)NULL;
8270 PL_reg_oldsaved = Nullch;
8271 PL_reg_oldsavedlen = 0;
8273 PL_reg_leftiter = 0;
8274 PL_reg_poscache = Nullch;
8275 PL_reg_poscache_size= 0;
8277 /* RE engine - function pointers */
8278 PL_regcompp = proto_perl->Tregcompp;
8279 PL_regexecp = proto_perl->Tregexecp;
8280 PL_regint_start = proto_perl->Tregint_start;
8281 PL_regint_string = proto_perl->Tregint_string;
8282 PL_regfree = proto_perl->Tregfree;
8284 PL_reginterp_cnt = 0;
8285 PL_reg_starttry = 0;
8288 return (PerlInterpreter*)pPerl;
8294 #else /* !USE_ITHREADS */
8300 #endif /* USE_ITHREADS */
8303 do_report_used(pTHXo_ SV *sv)
8305 if (SvTYPE(sv) != SVTYPEMASK) {
8306 PerlIO_printf(Perl_debug_log, "****\n");
8312 do_clean_objs(pTHXo_ SV *sv)
8316 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8317 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8323 /* XXX Might want to check arrays, etc. */
8326 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8328 do_clean_named_objs(pTHXo_ SV *sv)
8330 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8331 if ( SvOBJECT(GvSV(sv)) ||
8332 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8333 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8334 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8335 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8337 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8345 do_clean_all(pTHXo_ SV *sv)
8347 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8348 SvFLAGS(sv) |= SVf_BREAK;