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 (SvRV(tmpstr) != SvRV(sv)))
1493 return SvIV(tmpstr);
1494 return PTR2IV(SvRV(sv));
1496 if (SvREADONLY(sv) && !SvOK(sv)) {
1498 if (ckWARN(WARN_UNINITIALIZED))
1505 return (IV)(SvUVX(sv));
1512 /* We can cache the IV/UV value even if it not good enough
1513 * to reconstruct NV, since the conversion to PV will prefer
1517 if (SvTYPE(sv) == SVt_NV)
1518 sv_upgrade(sv, SVt_PVNV);
1521 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1522 SvIVX(sv) = I_V(SvNVX(sv));
1524 SvUVX(sv) = U_V(SvNVX(sv));
1527 DEBUG_c(PerlIO_printf(Perl_debug_log,
1528 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1532 return (IV)SvUVX(sv);
1535 else if (SvPOKp(sv) && SvLEN(sv)) {
1536 I32 numtype = looks_like_number(sv);
1538 /* We want to avoid a possible problem when we cache an IV which
1539 may be later translated to an NV, and the resulting NV is not
1540 the translation of the initial data.
1542 This means that if we cache such an IV, we need to cache the
1543 NV as well. Moreover, we trade speed for space, and do not
1544 cache the NV if not needed.
1546 if (numtype & IS_NUMBER_NOT_IV) {
1547 /* May be not an integer. Need to cache NV if we cache IV
1548 * - otherwise future conversion to NV will be wrong. */
1551 d = Atof(SvPVX(sv));
1553 if (SvTYPE(sv) < SVt_PVNV)
1554 sv_upgrade(sv, SVt_PVNV);
1558 #if defined(USE_LONG_DOUBLE)
1559 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1560 PTR2UV(sv), SvNVX(sv)));
1562 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%g)\n",
1563 PTR2UV(sv), SvNVX(sv)));
1565 if (SvNVX(sv) < (NV)IV_MAX + 0.5)
1566 SvIVX(sv) = I_V(SvNVX(sv));
1568 SvUVX(sv) = U_V(SvNVX(sv));
1573 else { /* The NV may be reconstructed from IV - safe to cache IV,
1574 which may be calculated by atol(). */
1575 if (SvTYPE(sv) < SVt_PVIV)
1576 sv_upgrade(sv, SVt_PVIV);
1578 SvIVX(sv) = Atol(SvPVX(sv));
1579 if (! numtype && ckWARN(WARN_NUMERIC))
1585 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1587 if (SvTYPE(sv) < SVt_IV)
1588 /* Typically the caller expects that sv_any is not NULL now. */
1589 sv_upgrade(sv, SVt_IV);
1592 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1593 PTR2UV(sv),SvIVX(sv)));
1594 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1598 Perl_sv_2uv(pTHX_ register SV *sv)
1602 if (SvGMAGICAL(sv)) {
1607 return U_V(SvNVX(sv));
1608 if (SvPOKp(sv) && SvLEN(sv))
1611 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1613 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1619 if (SvTHINKFIRST(sv)) {
1622 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1623 (SvRV(tmpstr) != SvRV(sv)))
1624 return SvUV(tmpstr);
1625 return PTR2UV(SvRV(sv));
1627 if (SvREADONLY(sv) && !SvOK(sv)) {
1629 if (ckWARN(WARN_UNINITIALIZED))
1639 return (UV)SvIVX(sv);
1643 /* We can cache the IV/UV value even if it not good enough
1644 * to reconstruct NV, since the conversion to PV will prefer
1647 if (SvTYPE(sv) == SVt_NV)
1648 sv_upgrade(sv, SVt_PVNV);
1650 if (SvNVX(sv) >= -0.5) {
1652 SvUVX(sv) = U_V(SvNVX(sv));
1655 SvIVX(sv) = I_V(SvNVX(sv));
1657 DEBUG_c(PerlIO_printf(Perl_debug_log,
1658 "0x%"UVxf" 2uv(%"IVdf" => %"IVdf") (as signed)\n",
1661 (IV)(UV)SvIVX(sv)));
1662 return (UV)SvIVX(sv);
1665 else if (SvPOKp(sv) && SvLEN(sv)) {
1666 I32 numtype = looks_like_number(sv);
1668 /* We want to avoid a possible problem when we cache a UV which
1669 may be later translated to an NV, and the resulting NV is not
1670 the translation of the initial data.
1672 This means that if we cache such a UV, we need to cache the
1673 NV as well. Moreover, we trade speed for space, and do not
1674 cache the NV if not needed.
1676 if (numtype & IS_NUMBER_NOT_IV) {
1677 /* May be not an integer. Need to cache NV if we cache IV
1678 * - otherwise future conversion to NV will be wrong. */
1681 d = Atof(SvPVX(sv));
1683 if (SvTYPE(sv) < SVt_PVNV)
1684 sv_upgrade(sv, SVt_PVNV);
1688 #if defined(USE_LONG_DOUBLE)
1689 DEBUG_c(PerlIO_printf(Perl_debug_log,
1690 "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1691 PTR2UV(sv), SvNVX(sv)));
1693 DEBUG_c(PerlIO_printf(Perl_debug_log,
1694 "0x%"UVxf" 2nv(%g)\n",
1695 PTR2UV(sv), SvNVX(sv)));
1697 if (SvNVX(sv) < -0.5) {
1698 SvIVX(sv) = I_V(SvNVX(sv));
1701 SvUVX(sv) = U_V(SvNVX(sv));
1705 else if (numtype & IS_NUMBER_NEG) {
1706 /* The NV may be reconstructed from IV - safe to cache IV,
1707 which may be calculated by atol(). */
1708 if (SvTYPE(sv) == SVt_PV)
1709 sv_upgrade(sv, SVt_PVIV);
1711 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1713 else if (numtype) { /* Non-negative */
1714 /* The NV may be reconstructed from UV - safe to cache UV,
1715 which may be calculated by strtoul()/atol. */
1716 if (SvTYPE(sv) == SVt_PV)
1717 sv_upgrade(sv, SVt_PVIV);
1719 (void)SvIsUV_on(sv);
1721 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1722 #else /* no atou(), but we know the number fits into IV... */
1723 /* The only problem may be if it is negative... */
1724 SvUVX(sv) = (UV)Atol(SvPVX(sv));
1727 else { /* Not a number. Cache 0. */
1730 if (SvTYPE(sv) < SVt_PVIV)
1731 sv_upgrade(sv, SVt_PVIV);
1733 (void)SvIsUV_on(sv);
1734 SvUVX(sv) = 0; /* We assume that 0s have the
1735 same bitmap in IV and UV. */
1736 if (ckWARN(WARN_NUMERIC))
1741 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1743 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1746 if (SvTYPE(sv) < SVt_IV)
1747 /* Typically the caller expects that sv_any is not NULL now. */
1748 sv_upgrade(sv, SVt_IV);
1752 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
1753 PTR2UV(sv),SvUVX(sv)));
1754 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
1758 Perl_sv_2nv(pTHX_ register SV *sv)
1762 if (SvGMAGICAL(sv)) {
1766 if (SvPOKp(sv) && SvLEN(sv)) {
1768 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1770 return Atof(SvPVX(sv));
1774 return (NV)SvUVX(sv);
1776 return (NV)SvIVX(sv);
1779 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1781 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1787 if (SvTHINKFIRST(sv)) {
1790 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1791 (SvRV(tmpstr) != SvRV(sv)))
1792 return SvNV(tmpstr);
1793 return PTR2NV(SvRV(sv));
1795 if (SvREADONLY(sv) && !SvOK(sv)) {
1797 if (ckWARN(WARN_UNINITIALIZED))
1802 if (SvTYPE(sv) < SVt_NV) {
1803 if (SvTYPE(sv) == SVt_IV)
1804 sv_upgrade(sv, SVt_PVNV);
1806 sv_upgrade(sv, SVt_NV);
1807 #if defined(USE_LONG_DOUBLE)
1809 STORE_NUMERIC_LOCAL_SET_STANDARD();
1810 PerlIO_printf(Perl_debug_log,
1811 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
1812 PTR2UV(sv), SvNVX(sv));
1813 RESTORE_NUMERIC_LOCAL();
1817 STORE_NUMERIC_LOCAL_SET_STANDARD();
1818 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
1819 PTR2UV(sv), SvNVX(sv));
1820 RESTORE_NUMERIC_LOCAL();
1824 else if (SvTYPE(sv) < SVt_PVNV)
1825 sv_upgrade(sv, SVt_PVNV);
1827 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
1829 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
1831 else if (SvPOKp(sv) && SvLEN(sv)) {
1833 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
1835 SvNVX(sv) = Atof(SvPVX(sv));
1839 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1841 if (SvTYPE(sv) < SVt_NV)
1842 /* Typically the caller expects that sv_any is not NULL now. */
1843 sv_upgrade(sv, SVt_NV);
1847 #if defined(USE_LONG_DOUBLE)
1849 STORE_NUMERIC_LOCAL_SET_STANDARD();
1850 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
1851 PTR2UV(sv), SvNVX(sv));
1852 RESTORE_NUMERIC_LOCAL();
1856 STORE_NUMERIC_LOCAL_SET_STANDARD();
1857 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
1858 PTR2UV(sv), SvNVX(sv));
1859 RESTORE_NUMERIC_LOCAL();
1866 S_asIV(pTHX_ SV *sv)
1868 I32 numtype = looks_like_number(sv);
1871 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1872 return Atol(SvPVX(sv));
1875 if (ckWARN(WARN_NUMERIC))
1878 d = Atof(SvPVX(sv));
1883 S_asUV(pTHX_ SV *sv)
1885 I32 numtype = looks_like_number(sv);
1888 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
1889 return Strtoul(SvPVX(sv), Null(char**), 10);
1893 if (ckWARN(WARN_NUMERIC))
1896 return U_V(Atof(SvPVX(sv)));
1900 * Returns a combination of (advisory only - can get false negatives)
1901 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF, IS_NUMBER_NOT_IV,
1903 * 0 if does not look like number.
1905 * In fact possible values are 0 and
1906 * IS_NUMBER_TO_INT_BY_ATOL 123
1907 * IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV 123.1
1908 * IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV 123e0
1909 * IS_NUMBER_INFINITY
1910 * with a possible addition of IS_NUMBER_NEG.
1914 =for apidoc looks_like_number
1916 Test if an the content of an SV looks like a number (or is a
1923 Perl_looks_like_number(pTHX_ SV *sv)
1926 register char *send;
1927 register char *sbegin;
1928 register char *nbegin;
1937 else if (SvPOKp(sv))
1938 sbegin = SvPV(sv, len);
1941 send = sbegin + len;
1948 numtype = IS_NUMBER_NEG;
1955 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can be converted
1956 * to _integer_ with atol() and IS_NUMBER_TO_INT_BY_ATOF if you need
1960 /* next must be digit or the radix separator or beginning of infinity */
1964 } while (isDIGIT(*s));
1966 if (s - nbegin >= TYPE_DIGITS(IV)) /* Cannot cache ato[ul]() */
1967 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
1969 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
1972 #ifdef USE_LOCALE_NUMERIC
1973 || IS_NUMERIC_RADIX(*s)
1977 numtype |= IS_NUMBER_NOT_IV;
1978 while (isDIGIT(*s)) /* optional digits after the radix */
1983 #ifdef USE_LOCALE_NUMERIC
1984 || IS_NUMERIC_RADIX(*s)
1988 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_IV;
1989 /* no digits before the radix means we need digits after it */
1993 } while (isDIGIT(*s));
1998 else if (*s == 'I' || *s == 'i') {
1999 s++; if (*s != 'N' && *s != 'n') return 0;
2000 s++; if (*s != 'F' && *s != 'f') return 0;
2001 s++; if (*s == 'I' || *s == 'i') {
2002 s++; if (*s != 'N' && *s != 'n') return 0;
2003 s++; if (*s != 'I' && *s != 'i') return 0;
2004 s++; if (*s != 'T' && *s != 't') return 0;
2005 s++; if (*s != 'Y' && *s != 'y') return 0;
2013 numtype = IS_NUMBER_INFINITY;
2015 /* we can have an optional exponent part */
2016 if (*s == 'e' || *s == 'E') {
2017 numtype &= ~IS_NUMBER_NEG;
2018 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_IV;
2020 if (*s == '+' || *s == '-')
2025 } while (isDIGIT(*s));
2035 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2036 return IS_NUMBER_TO_INT_BY_ATOL;
2041 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2044 return sv_2pv(sv, &n_a);
2047 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2049 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2051 char *ptr = buf + TYPE_CHARS(UV);
2065 *--ptr = '0' + (uv % 10);
2074 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2079 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2080 char *tmpbuf = tbuf;
2086 if (SvGMAGICAL(sv)) {
2094 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2096 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2101 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2106 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2108 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2115 if (SvTHINKFIRST(sv)) {
2118 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2119 (SvRV(tmpstr) != SvRV(sv)))
2120 return SvPV(tmpstr,*lp);
2127 switch (SvTYPE(sv)) {
2129 if ( ((SvFLAGS(sv) &
2130 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2131 == (SVs_OBJECT|SVs_RMG))
2132 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2133 && (mg = mg_find(sv, 'r'))) {
2135 regexp *re = (regexp *)mg->mg_obj;
2138 char *fptr = "msix";
2143 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2145 while((ch = *fptr++)) {
2147 reflags[left++] = ch;
2150 reflags[right--] = ch;
2155 reflags[left] = '-';
2159 mg->mg_len = re->prelen + 4 + left;
2160 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2161 Copy("(?", mg->mg_ptr, 2, char);
2162 Copy(reflags, mg->mg_ptr+2, left, char);
2163 Copy(":", mg->mg_ptr+left+2, 1, char);
2164 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2165 mg->mg_ptr[mg->mg_len - 1] = ')';
2166 mg->mg_ptr[mg->mg_len] = 0;
2168 PL_reginterp_cnt += re->program[0].next_off;
2180 case SVt_PVBM: if (SvROK(sv))
2183 s = "SCALAR"; break;
2184 case SVt_PVLV: s = "LVALUE"; break;
2185 case SVt_PVAV: s = "ARRAY"; break;
2186 case SVt_PVHV: s = "HASH"; break;
2187 case SVt_PVCV: s = "CODE"; break;
2188 case SVt_PVGV: s = "GLOB"; break;
2189 case SVt_PVFM: s = "FORMAT"; break;
2190 case SVt_PVIO: s = "IO"; break;
2191 default: s = "UNKNOWN"; break;
2195 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2198 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2204 if (SvREADONLY(sv) && !SvOK(sv)) {
2206 if (ckWARN(WARN_UNINITIALIZED))
2212 if (SvNOKp(sv)) { /* See note in sv_2uv() */
2213 /* XXXX 64-bit? IV may have better precision... */
2214 /* I tried changing this to be 64-bit-aware and
2215 * the t/op/numconvert.t became very, very, angry.
2217 if (SvTYPE(sv) < SVt_PVNV)
2218 sv_upgrade(sv, SVt_PVNV);
2219 /* The +20 is pure guesswork. Configure test needed. --jhi */
2220 SvGROW(sv, NV_DIG + 20);
2222 olderrno = errno; /* some Xenix systems wipe out errno here */
2224 if (SvNVX(sv) == 0.0)
2225 (void)strcpy(s,"0");
2229 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2232 #ifdef FIXNEGATIVEZERO
2233 if (*s == '-' && s[1] == '0' && !s[2])
2242 else if (SvIOKp(sv)) {
2243 U32 isIOK = SvIOK(sv);
2244 U32 isUIOK = SvIsUV(sv);
2245 char buf[TYPE_CHARS(UV)];
2248 if (SvTYPE(sv) < SVt_PVIV)
2249 sv_upgrade(sv, SVt_PVIV);
2251 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2253 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2254 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2255 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2256 SvCUR_set(sv, ebuf - ptr);
2269 if (ckWARN(WARN_UNINITIALIZED)
2270 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2275 if (SvTYPE(sv) < SVt_PV)
2276 /* Typically the caller expects that sv_any is not NULL now. */
2277 sv_upgrade(sv, SVt_PV);
2280 *lp = s - SvPVX(sv);
2283 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2284 PTR2UV(sv),SvPVX(sv)));
2288 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2289 /* Sneaky stuff here */
2293 tsv = newSVpv(tmpbuf, 0);
2309 len = strlen(tmpbuf);
2311 #ifdef FIXNEGATIVEZERO
2312 if (len == 2 && t[0] == '-' && t[1] == '0') {
2317 (void)SvUPGRADE(sv, SVt_PV);
2319 s = SvGROW(sv, len + 1);
2328 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2331 return sv_2pvbyte(sv, &n_a);
2335 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2337 return sv_2pv(sv,lp);
2341 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2344 return sv_2pvutf8(sv, &n_a);
2348 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2350 sv_utf8_upgrade(sv);
2351 return sv_2pv(sv,lp);
2354 /* This function is only called on magical items */
2356 Perl_sv_2bool(pTHX_ register SV *sv)
2366 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2367 (SvRV(tmpsv) != SvRV(sv)))
2368 return SvTRUE(tmpsv);
2369 return SvRV(sv) != 0;
2372 register XPV* Xpvtmp;
2373 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2374 (*Xpvtmp->xpv_pv > '0' ||
2375 Xpvtmp->xpv_cur > 1 ||
2376 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2383 return SvIVX(sv) != 0;
2386 return SvNVX(sv) != 0.0;
2394 =for apidoc sv_utf8_upgrade
2396 Convert the PV of an SV to its UTF8-encoded form.
2402 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2407 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2410 /* This function could be much more efficient if we had a FLAG in SVs
2411 * to signal if there are any hibit chars in the PV.
2413 for (s = t = SvPVX(sv), hibit = FALSE; t < SvEND(sv) && !hibit; t++)
2418 STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */
2419 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2420 SvCUR(sv) = len - 1;
2421 SvLEN(sv) = len; /* No longer know the real size. */
2423 Safefree(s); /* No longer using what was there before. */
2428 =for apidoc sv_utf8_downgrade
2430 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2431 This may not be possible if the PV contains non-byte encoding characters;
2432 if this is the case, either returns false or, if C<fail_ok> is not
2439 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2441 if (SvPOK(sv) && SvUTF8(sv)) {
2442 char *c = SvPVX(sv);
2443 STRLEN len = SvCUR(sv) + 1; /* include trailing NUL */
2444 if (!utf8_to_bytes((U8*)c, &len)) {
2448 Perl_croak(aTHX_ "big byte");
2450 SvCUR(sv) = len - 1;
2457 =for apidoc sv_utf8_encode
2459 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2460 flag so that it looks like bytes again. Nothing calls this.
2466 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2468 sv_utf8_upgrade(sv);
2473 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2477 bool has_utf = FALSE;
2478 if (!sv_utf8_downgrade(sv, TRUE))
2481 /* it is actually just a matter of turning the utf8 flag on, but
2482 * we want to make sure everything inside is valid utf8 first.
2485 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
2488 while (c < SvEND(sv)) {
2499 /* Note: sv_setsv() should not be called with a source string that needs
2500 * to be reused, since it may destroy the source string if it is marked
2505 =for apidoc sv_setsv
2507 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
2508 The source SV may be destroyed if it is mortal. Does not handle 'set'
2509 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
2516 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
2519 register U32 sflags;
2525 SV_CHECK_THINKFIRST(dstr);
2527 sstr = &PL_sv_undef;
2528 stype = SvTYPE(sstr);
2529 dtype = SvTYPE(dstr);
2533 /* There's a lot of redundancy below but we're going for speed here */
2538 if (dtype != SVt_PVGV) {
2539 (void)SvOK_off(dstr);
2547 sv_upgrade(dstr, SVt_IV);
2550 sv_upgrade(dstr, SVt_PVNV);
2554 sv_upgrade(dstr, SVt_PVIV);
2557 (void)SvIOK_only(dstr);
2558 SvIVX(dstr) = SvIVX(sstr);
2571 sv_upgrade(dstr, SVt_NV);
2576 sv_upgrade(dstr, SVt_PVNV);
2579 SvNVX(dstr) = SvNVX(sstr);
2580 (void)SvNOK_only(dstr);
2588 sv_upgrade(dstr, SVt_RV);
2589 else if (dtype == SVt_PVGV &&
2590 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
2593 if (GvIMPORTED(dstr) != GVf_IMPORTED
2594 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2596 GvIMPORTED_on(dstr);
2607 sv_upgrade(dstr, SVt_PV);
2610 if (dtype < SVt_PVIV)
2611 sv_upgrade(dstr, SVt_PVIV);
2614 if (dtype < SVt_PVNV)
2615 sv_upgrade(dstr, SVt_PVNV);
2622 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
2623 PL_op_name[PL_op->op_type]);
2625 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
2629 if (dtype <= SVt_PVGV) {
2631 if (dtype != SVt_PVGV) {
2632 char *name = GvNAME(sstr);
2633 STRLEN len = GvNAMELEN(sstr);
2634 sv_upgrade(dstr, SVt_PVGV);
2635 sv_magic(dstr, dstr, '*', Nullch, 0);
2636 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
2637 GvNAME(dstr) = savepvn(name, len);
2638 GvNAMELEN(dstr) = len;
2639 SvFAKE_on(dstr); /* can coerce to non-glob */
2641 /* ahem, death to those who redefine active sort subs */
2642 else if (PL_curstackinfo->si_type == PERLSI_SORT
2643 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
2644 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
2646 (void)SvOK_off(dstr);
2647 GvINTRO_off(dstr); /* one-shot flag */
2649 GvGP(dstr) = gp_ref(GvGP(sstr));
2651 if (GvIMPORTED(dstr) != GVf_IMPORTED
2652 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2654 GvIMPORTED_on(dstr);
2662 if (SvGMAGICAL(sstr)) {
2664 if (SvTYPE(sstr) != stype) {
2665 stype = SvTYPE(sstr);
2666 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
2670 if (stype == SVt_PVLV)
2671 (void)SvUPGRADE(dstr, SVt_PVNV);
2673 (void)SvUPGRADE(dstr, stype);
2676 sflags = SvFLAGS(sstr);
2678 if (sflags & SVf_ROK) {
2679 if (dtype >= SVt_PV) {
2680 if (dtype == SVt_PVGV) {
2681 SV *sref = SvREFCNT_inc(SvRV(sstr));
2683 int intro = GvINTRO(dstr);
2688 GvINTRO_off(dstr); /* one-shot flag */
2689 Newz(602,gp, 1, GP);
2690 GvGP(dstr) = gp_ref(gp);
2691 GvSV(dstr) = NEWSV(72,0);
2692 GvLINE(dstr) = CopLINE(PL_curcop);
2693 GvEGV(dstr) = (GV*)dstr;
2696 switch (SvTYPE(sref)) {
2699 SAVESPTR(GvAV(dstr));
2701 dref = (SV*)GvAV(dstr);
2702 GvAV(dstr) = (AV*)sref;
2703 if (!GvIMPORTED_AV(dstr)
2704 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2706 GvIMPORTED_AV_on(dstr);
2711 SAVESPTR(GvHV(dstr));
2713 dref = (SV*)GvHV(dstr);
2714 GvHV(dstr) = (HV*)sref;
2715 if (!GvIMPORTED_HV(dstr)
2716 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2718 GvIMPORTED_HV_on(dstr);
2723 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
2724 SvREFCNT_dec(GvCV(dstr));
2725 GvCV(dstr) = Nullcv;
2726 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2727 PL_sub_generation++;
2729 SAVESPTR(GvCV(dstr));
2732 dref = (SV*)GvCV(dstr);
2733 if (GvCV(dstr) != (CV*)sref) {
2734 CV* cv = GvCV(dstr);
2736 if (!GvCVGEN((GV*)dstr) &&
2737 (CvROOT(cv) || CvXSUB(cv)))
2739 SV *const_sv = cv_const_sv(cv);
2740 bool const_changed = TRUE;
2742 const_changed = sv_cmp(const_sv,
2743 op_const_sv(CvSTART((CV*)sref),
2745 /* ahem, death to those who redefine
2746 * active sort subs */
2747 if (PL_curstackinfo->si_type == PERLSI_SORT &&
2748 PL_sortcop == CvSTART(cv))
2750 "Can't redefine active sort subroutine %s",
2751 GvENAME((GV*)dstr));
2752 if ((const_changed && const_sv) || ckWARN(WARN_REDEFINE))
2753 Perl_warner(aTHX_ WARN_REDEFINE, const_sv ?
2754 "Constant subroutine %s redefined"
2755 : "Subroutine %s redefined",
2756 GvENAME((GV*)dstr));
2758 cv_ckproto(cv, (GV*)dstr,
2759 SvPOK(sref) ? SvPVX(sref) : Nullch);
2761 GvCV(dstr) = (CV*)sref;
2762 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
2763 GvASSUMECV_on(dstr);
2764 PL_sub_generation++;
2766 if (!GvIMPORTED_CV(dstr)
2767 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2769 GvIMPORTED_CV_on(dstr);
2774 SAVESPTR(GvIOp(dstr));
2776 dref = (SV*)GvIOp(dstr);
2777 GvIOp(dstr) = (IO*)sref;
2781 SAVESPTR(GvFORM(dstr));
2783 dref = (SV*)GvFORM(dstr);
2784 GvFORM(dstr) = (CV*)sref;
2788 SAVESPTR(GvSV(dstr));
2790 dref = (SV*)GvSV(dstr);
2792 if (!GvIMPORTED_SV(dstr)
2793 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
2795 GvIMPORTED_SV_on(dstr);
2807 (void)SvOOK_off(dstr); /* backoff */
2809 Safefree(SvPVX(dstr));
2810 SvLEN(dstr)=SvCUR(dstr)=0;
2813 (void)SvOK_off(dstr);
2814 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
2816 if (sflags & SVp_NOK) {
2818 SvNVX(dstr) = SvNVX(sstr);
2820 if (sflags & SVp_IOK) {
2821 (void)SvIOK_on(dstr);
2822 SvIVX(dstr) = SvIVX(sstr);
2823 if (sflags & SVf_IVisUV)
2826 if (SvAMAGIC(sstr)) {
2830 else if (sflags & SVp_POK) {
2833 * Check to see if we can just swipe the string. If so, it's a
2834 * possible small lose on short strings, but a big win on long ones.
2835 * It might even be a win on short strings if SvPVX(dstr)
2836 * has to be allocated and SvPVX(sstr) has to be freed.
2839 if (SvTEMP(sstr) && /* slated for free anyway? */
2840 SvREFCNT(sstr) == 1 && /* and no other references to it? */
2841 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
2842 SvLEN(sstr)) /* and really is a string */
2844 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
2846 SvFLAGS(dstr) &= ~SVf_OOK;
2847 Safefree(SvPVX(dstr) - SvIVX(dstr));
2849 else if (SvLEN(dstr))
2850 Safefree(SvPVX(dstr));
2852 (void)SvPOK_only(dstr);
2853 SvPV_set(dstr, SvPVX(sstr));
2854 SvLEN_set(dstr, SvLEN(sstr));
2855 SvCUR_set(dstr, SvCUR(sstr));
2858 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
2859 SvPV_set(sstr, Nullch);
2864 else { /* have to copy actual string */
2865 STRLEN len = SvCUR(sstr);
2867 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
2868 Move(SvPVX(sstr),SvPVX(dstr),len,char);
2869 SvCUR_set(dstr, len);
2870 *SvEND(dstr) = '\0';
2871 (void)SvPOK_only(dstr);
2873 if ((sflags & SVf_UTF8) && !IN_BYTE)
2876 if (sflags & SVp_NOK) {
2878 SvNVX(dstr) = SvNVX(sstr);
2880 if (sflags & SVp_IOK) {
2881 (void)SvIOK_on(dstr);
2882 SvIVX(dstr) = SvIVX(sstr);
2883 if (sflags & SVf_IVisUV)
2887 else if (sflags & SVp_NOK) {
2888 SvNVX(dstr) = SvNVX(sstr);
2889 (void)SvNOK_only(dstr);
2890 if (sflags & SVf_IOK) {
2891 (void)SvIOK_on(dstr);
2892 SvIVX(dstr) = SvIVX(sstr);
2893 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
2894 if (sflags & SVf_IVisUV)
2898 else if (sflags & SVp_IOK) {
2899 (void)SvIOK_only(dstr);
2900 SvIVX(dstr) = SvIVX(sstr);
2901 if (sflags & SVf_IVisUV)
2905 if (dtype == SVt_PVGV) {
2906 if (ckWARN(WARN_MISC))
2907 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
2910 (void)SvOK_off(dstr);
2916 =for apidoc sv_setsv_mg
2918 Like C<sv_setsv>, but also handles 'set' magic.
2924 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
2926 sv_setsv(dstr,sstr);
2931 =for apidoc sv_setpvn
2933 Copies a string into an SV. The C<len> parameter indicates the number of
2934 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
2940 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2942 register char *dptr;
2943 assert(len >= 0); /* STRLEN is probably unsigned, so this may
2944 elicit a warning, but it won't hurt. */
2945 SV_CHECK_THINKFIRST(sv);
2950 (void)SvUPGRADE(sv, SVt_PV);
2952 SvGROW(sv, len + 1);
2954 Move(ptr,dptr,len,char);
2957 (void)SvPOK_only(sv); /* validate pointer */
2962 =for apidoc sv_setpvn_mg
2964 Like C<sv_setpvn>, but also handles 'set' magic.
2970 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
2972 sv_setpvn(sv,ptr,len);
2977 =for apidoc sv_setpv
2979 Copies a string into an SV. The string must be null-terminated. Does not
2980 handle 'set' magic. See C<sv_setpv_mg>.
2986 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
2988 register STRLEN len;
2990 SV_CHECK_THINKFIRST(sv);
2996 (void)SvUPGRADE(sv, SVt_PV);
2998 SvGROW(sv, len + 1);
2999 Move(ptr,SvPVX(sv),len+1,char);
3001 (void)SvPOK_only(sv); /* validate pointer */
3006 =for apidoc sv_setpv_mg
3008 Like C<sv_setpv>, but also handles 'set' magic.
3014 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3021 =for apidoc sv_usepvn
3023 Tells an SV to use C<ptr> to find its string value. Normally the string is
3024 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3025 The C<ptr> should point to memory that was allocated by C<malloc>. The
3026 string length, C<len>, must be supplied. This function will realloc the
3027 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3028 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3029 See C<sv_usepvn_mg>.
3035 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3037 SV_CHECK_THINKFIRST(sv);
3038 (void)SvUPGRADE(sv, SVt_PV);
3043 (void)SvOOK_off(sv);
3044 if (SvPVX(sv) && SvLEN(sv))
3045 Safefree(SvPVX(sv));
3046 Renew(ptr, len+1, char);
3049 SvLEN_set(sv, len+1);
3051 (void)SvPOK_only(sv); /* validate pointer */
3056 =for apidoc sv_usepvn_mg
3058 Like C<sv_usepvn>, but also handles 'set' magic.
3064 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3066 sv_usepvn(sv,ptr,len);
3071 Perl_sv_force_normal(pTHX_ register SV *sv)
3073 if (SvREADONLY(sv)) {
3076 char *pvx = SvPVX(sv);
3077 STRLEN len = SvCUR(sv);
3078 U32 hash = SvUVX(sv);
3079 SvGROW(sv, len + 1);
3080 Move(pvx,SvPVX(sv),len,char);
3084 unsharepvn(pvx,len,hash);
3086 else if (PL_curcop != &PL_compiling)
3087 Perl_croak(aTHX_ PL_no_modify);
3091 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3098 Efficient removal of characters from the beginning of the string buffer.
3099 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3100 the string buffer. The C<ptr> becomes the first character of the adjusted
3107 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3111 register STRLEN delta;
3113 if (!ptr || !SvPOKp(sv))
3115 SV_CHECK_THINKFIRST(sv);
3116 if (SvTYPE(sv) < SVt_PVIV)
3117 sv_upgrade(sv,SVt_PVIV);
3120 if (!SvLEN(sv)) { /* make copy of shared string */
3121 char *pvx = SvPVX(sv);
3122 STRLEN len = SvCUR(sv);
3123 SvGROW(sv, len + 1);
3124 Move(pvx,SvPVX(sv),len,char);
3128 SvFLAGS(sv) |= SVf_OOK;
3130 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3131 delta = ptr - SvPVX(sv);
3139 =for apidoc sv_catpvn
3141 Concatenates the string onto the end of the string which is in the SV. The
3142 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3143 'set' magic. See C<sv_catpvn_mg>.
3149 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3154 junk = SvPV_force(sv, tlen);
3155 SvGROW(sv, tlen + len + 1);
3158 Move(ptr,SvPVX(sv)+tlen,len,char);
3161 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3166 =for apidoc sv_catpvn_mg
3168 Like C<sv_catpvn>, but also handles 'set' magic.
3174 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3176 sv_catpvn(sv,ptr,len);
3181 =for apidoc sv_catsv
3183 Concatenates the string from SV C<ssv> onto the end of the string in SV
3184 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3190 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3196 if ((s = SvPV(sstr, len))) {
3197 if (DO_UTF8(sstr)) {
3198 sv_utf8_upgrade(dstr);
3199 sv_catpvn(dstr,s,len);
3203 sv_catpvn(dstr,s,len);
3208 =for apidoc sv_catsv_mg
3210 Like C<sv_catsv>, but also handles 'set' magic.
3216 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3218 sv_catsv(dstr,sstr);
3223 =for apidoc sv_catpv
3225 Concatenates the string onto the end of the string which is in the SV.
3226 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3232 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3234 register STRLEN len;
3240 junk = SvPV_force(sv, tlen);
3242 SvGROW(sv, tlen + len + 1);
3245 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3247 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3252 =for apidoc sv_catpv_mg
3254 Like C<sv_catpv>, but also handles 'set' magic.
3260 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3267 Perl_newSV(pTHX_ STRLEN len)
3273 sv_upgrade(sv, SVt_PV);
3274 SvGROW(sv, len + 1);
3279 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3282 =for apidoc sv_magic
3284 Adds magic to an SV.
3290 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3294 if (SvREADONLY(sv)) {
3296 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3297 Perl_croak(aTHX_ PL_no_modify);
3299 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3300 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3307 (void)SvUPGRADE(sv, SVt_PVMG);
3309 Newz(702,mg, 1, MAGIC);
3310 mg->mg_moremagic = SvMAGIC(sv);
3313 if (!obj || obj == sv || how == '#' || how == 'r')
3317 mg->mg_obj = SvREFCNT_inc(obj);
3318 mg->mg_flags |= MGf_REFCOUNTED;
3321 mg->mg_len = namlen;
3324 mg->mg_ptr = savepvn(name, namlen);
3325 else if (namlen == HEf_SVKEY)
3326 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3330 mg->mg_virtual = &PL_vtbl_sv;
3333 mg->mg_virtual = &PL_vtbl_amagic;
3336 mg->mg_virtual = &PL_vtbl_amagicelem;
3342 mg->mg_virtual = &PL_vtbl_bm;
3345 mg->mg_virtual = &PL_vtbl_regdata;
3348 mg->mg_virtual = &PL_vtbl_regdatum;
3351 mg->mg_virtual = &PL_vtbl_env;
3354 mg->mg_virtual = &PL_vtbl_fm;
3357 mg->mg_virtual = &PL_vtbl_envelem;
3360 mg->mg_virtual = &PL_vtbl_mglob;
3363 mg->mg_virtual = &PL_vtbl_isa;
3366 mg->mg_virtual = &PL_vtbl_isaelem;
3369 mg->mg_virtual = &PL_vtbl_nkeys;
3376 mg->mg_virtual = &PL_vtbl_dbline;
3380 mg->mg_virtual = &PL_vtbl_mutex;
3382 #endif /* USE_THREADS */
3383 #ifdef USE_LOCALE_COLLATE
3385 mg->mg_virtual = &PL_vtbl_collxfrm;
3387 #endif /* USE_LOCALE_COLLATE */
3389 mg->mg_virtual = &PL_vtbl_pack;
3393 mg->mg_virtual = &PL_vtbl_packelem;
3396 mg->mg_virtual = &PL_vtbl_regexp;
3399 mg->mg_virtual = &PL_vtbl_sig;
3402 mg->mg_virtual = &PL_vtbl_sigelem;
3405 mg->mg_virtual = &PL_vtbl_taint;
3409 mg->mg_virtual = &PL_vtbl_uvar;
3412 mg->mg_virtual = &PL_vtbl_vec;
3415 mg->mg_virtual = &PL_vtbl_substr;
3418 mg->mg_virtual = &PL_vtbl_defelem;
3421 mg->mg_virtual = &PL_vtbl_glob;
3424 mg->mg_virtual = &PL_vtbl_arylen;
3427 mg->mg_virtual = &PL_vtbl_pos;
3430 mg->mg_virtual = &PL_vtbl_backref;
3432 case '~': /* Reserved for use by extensions not perl internals. */
3433 /* Useful for attaching extension internal data to perl vars. */
3434 /* Note that multiple extensions may clash if magical scalars */
3435 /* etc holding private data from one are passed to another. */
3439 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3443 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3447 =for apidoc sv_unmagic
3449 Removes magic from an SV.
3455 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3459 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3462 for (mg = *mgp; mg; mg = *mgp) {
3463 if (mg->mg_type == type) {
3464 MGVTBL* vtbl = mg->mg_virtual;
3465 *mgp = mg->mg_moremagic;
3466 if (vtbl && vtbl->svt_free)
3467 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3468 if (mg->mg_ptr && mg->mg_type != 'g')
3469 if (mg->mg_len >= 0)
3470 Safefree(mg->mg_ptr);
3471 else if (mg->mg_len == HEf_SVKEY)
3472 SvREFCNT_dec((SV*)mg->mg_ptr);
3473 if (mg->mg_flags & MGf_REFCOUNTED)
3474 SvREFCNT_dec(mg->mg_obj);
3478 mgp = &mg->mg_moremagic;
3482 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
3489 =for apidoc sv_rvweaken
3497 Perl_sv_rvweaken(pTHX_ SV *sv)
3500 if (!SvOK(sv)) /* let undefs pass */
3503 Perl_croak(aTHX_ "Can't weaken a nonreference");
3504 else if (SvWEAKREF(sv)) {
3506 if (ckWARN(WARN_MISC))
3507 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
3511 sv_add_backref(tsv, sv);
3518 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
3522 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
3523 av = (AV*)mg->mg_obj;
3526 sv_magic(tsv, (SV*)av, '<', NULL, 0);
3527 SvREFCNT_dec(av); /* for sv_magic */
3533 S_sv_del_backref(pTHX_ SV *sv)
3540 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
3541 Perl_croak(aTHX_ "panic: del_backref");
3542 av = (AV *)mg->mg_obj;
3547 svp[i] = &PL_sv_undef; /* XXX */
3554 =for apidoc sv_insert
3556 Inserts a string at the specified offset/length within the SV. Similar to
3557 the Perl substr() function.
3563 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
3567 register char *midend;
3568 register char *bigend;
3574 Perl_croak(aTHX_ "Can't modify non-existent substring");
3575 SvPV_force(bigstr, curlen);
3576 (void)SvPOK_only_UTF8(bigstr);
3577 if (offset + len > curlen) {
3578 SvGROW(bigstr, offset+len+1);
3579 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
3580 SvCUR_set(bigstr, offset+len);
3584 i = littlelen - len;
3585 if (i > 0) { /* string might grow */
3586 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
3587 mid = big + offset + len;
3588 midend = bigend = big + SvCUR(bigstr);
3591 while (midend > mid) /* shove everything down */
3592 *--bigend = *--midend;
3593 Move(little,big+offset,littlelen,char);
3599 Move(little,SvPVX(bigstr)+offset,len,char);
3604 big = SvPVX(bigstr);
3607 bigend = big + SvCUR(bigstr);
3609 if (midend > bigend)
3610 Perl_croak(aTHX_ "panic: sv_insert");
3612 if (mid - big > bigend - midend) { /* faster to shorten from end */
3614 Move(little, mid, littlelen,char);
3617 i = bigend - midend;
3619 Move(midend, mid, i,char);
3623 SvCUR_set(bigstr, mid - big);
3626 else if ((i = mid - big)) { /* faster from front */
3627 midend -= littlelen;
3629 sv_chop(bigstr,midend-i);
3634 Move(little, mid, littlelen,char);
3636 else if (littlelen) {
3637 midend -= littlelen;
3638 sv_chop(bigstr,midend);
3639 Move(little,midend,littlelen,char);
3642 sv_chop(bigstr,midend);
3648 =for apidoc sv_replace
3650 Make the first argument a copy of the second, then delete the original.
3656 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
3659 U32 refcnt = SvREFCNT(sv);
3660 SV_CHECK_THINKFIRST(sv);
3661 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
3662 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
3663 if (SvMAGICAL(sv)) {
3667 sv_upgrade(nsv, SVt_PVMG);
3668 SvMAGIC(nsv) = SvMAGIC(sv);
3669 SvFLAGS(nsv) |= SvMAGICAL(sv);
3675 assert(!SvREFCNT(sv));
3676 StructCopy(nsv,sv,SV);
3677 SvREFCNT(sv) = refcnt;
3678 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
3683 =for apidoc sv_clear
3685 Clear an SV, making it empty. Does not free the memory used by the SV
3692 Perl_sv_clear(pTHX_ register SV *sv)
3696 assert(SvREFCNT(sv) == 0);
3700 if (PL_defstash) { /* Still have a symbol table? */
3705 Zero(&tmpref, 1, SV);
3706 sv_upgrade(&tmpref, SVt_RV);
3708 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
3709 SvREFCNT(&tmpref) = 1;
3712 stash = SvSTASH(sv);
3713 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
3716 PUSHSTACKi(PERLSI_DESTROY);
3717 SvRV(&tmpref) = SvREFCNT_inc(sv);
3722 call_sv((SV*)GvCV(destructor),
3723 G_DISCARD|G_EVAL|G_KEEPERR);
3729 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
3731 del_XRV(SvANY(&tmpref));
3734 if (PL_in_clean_objs)
3735 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
3737 /* DESTROY gave object new lease on life */
3743 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
3744 SvOBJECT_off(sv); /* Curse the object. */
3745 if (SvTYPE(sv) != SVt_PVIO)
3746 --PL_sv_objcount; /* XXX Might want something more general */
3749 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
3752 switch (SvTYPE(sv)) {
3755 IoIFP(sv) != PerlIO_stdin() &&
3756 IoIFP(sv) != PerlIO_stdout() &&
3757 IoIFP(sv) != PerlIO_stderr())
3759 io_close((IO*)sv, FALSE);
3761 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
3762 PerlDir_close(IoDIRP(sv));
3763 IoDIRP(sv) = (DIR*)NULL;
3764 Safefree(IoTOP_NAME(sv));
3765 Safefree(IoFMT_NAME(sv));
3766 Safefree(IoBOTTOM_NAME(sv));
3781 SvREFCNT_dec(LvTARG(sv));
3785 Safefree(GvNAME(sv));
3786 /* cannot decrease stash refcount yet, as we might recursively delete
3787 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
3788 of stash until current sv is completely gone.
3789 -- JohnPC, 27 Mar 1998 */
3790 stash = GvSTASH(sv);
3796 (void)SvOOK_off(sv);
3804 SvREFCNT_dec(SvRV(sv));
3806 else if (SvPVX(sv) && SvLEN(sv))
3807 Safefree(SvPVX(sv));
3808 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
3809 unsharepvn(SvPVX(sv),SvCUR(sv),SvUVX(sv));
3821 switch (SvTYPE(sv)) {
3837 del_XPVIV(SvANY(sv));
3840 del_XPVNV(SvANY(sv));
3843 del_XPVMG(SvANY(sv));
3846 del_XPVLV(SvANY(sv));
3849 del_XPVAV(SvANY(sv));
3852 del_XPVHV(SvANY(sv));
3855 del_XPVCV(SvANY(sv));
3858 del_XPVGV(SvANY(sv));
3859 /* code duplication for increased performance. */
3860 SvFLAGS(sv) &= SVf_BREAK;
3861 SvFLAGS(sv) |= SVTYPEMASK;
3862 /* decrease refcount of the stash that owns this GV, if any */
3864 SvREFCNT_dec(stash);
3865 return; /* not break, SvFLAGS reset already happened */
3867 del_XPVBM(SvANY(sv));
3870 del_XPVFM(SvANY(sv));
3873 del_XPVIO(SvANY(sv));
3876 SvFLAGS(sv) &= SVf_BREAK;
3877 SvFLAGS(sv) |= SVTYPEMASK;
3881 Perl_sv_newref(pTHX_ SV *sv)
3884 ATOMIC_INC(SvREFCNT(sv));
3891 Free the memory used by an SV.
3897 Perl_sv_free(pTHX_ SV *sv)
3900 int refcount_is_zero;
3904 if (SvREFCNT(sv) == 0) {
3905 if (SvFLAGS(sv) & SVf_BREAK)
3907 if (PL_in_clean_all) /* All is fair */
3909 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3910 /* make sure SvREFCNT(sv)==0 happens very seldom */
3911 SvREFCNT(sv) = (~(U32)0)/2;
3914 if (ckWARN_d(WARN_INTERNAL))
3915 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
3918 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
3919 if (!refcount_is_zero)
3923 if (ckWARN_d(WARN_DEBUGGING))
3924 Perl_warner(aTHX_ WARN_DEBUGGING,
3925 "Attempt to free temp prematurely: SV 0x%"UVxf,
3930 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
3931 /* make sure SvREFCNT(sv)==0 happens very seldom */
3932 SvREFCNT(sv) = (~(U32)0)/2;
3943 Returns the length of the string in the SV. See also C<SvCUR>.
3949 Perl_sv_len(pTHX_ register SV *sv)
3958 len = mg_length(sv);
3960 junk = SvPV(sv, len);
3965 =for apidoc sv_len_utf8
3967 Returns the number of characters in the string in an SV, counting wide
3968 UTF8 bytes as a single character.
3974 Perl_sv_len_utf8(pTHX_ register SV *sv)
3985 len = mg_length(sv);
3988 s = (U8*)SvPV(sv, len);
3999 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4004 I32 uoffset = *offsetp;
4010 start = s = (U8*)SvPV(sv, len);
4012 while (s < send && uoffset--)
4016 *offsetp = s - start;
4020 while (s < send && ulen--)
4030 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4039 s = (U8*)SvPV(sv, len);
4041 Perl_croak(aTHX_ "panic: bad byte offset");
4042 send = s + *offsetp;
4050 if (ckWARN_d(WARN_UTF8))
4051 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4061 Returns a boolean indicating whether the strings in the two SVs are
4068 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4075 bool pv1tmp = FALSE;
4076 bool pv2tmp = FALSE;
4083 pv1 = SvPV(sv1, cur1);
4090 pv2 = SvPV(sv2, cur2);
4092 /* do not utf8ize the comparands as a side-effect */
4093 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE && 0) {
4095 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4099 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4105 eq = memEQ(pv1, pv2, cur1);
4118 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4119 string in C<sv1> is less than, equal to, or greater than the string in
4126 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4131 bool pv1tmp = FALSE;
4132 bool pv2tmp = FALSE;
4139 pv1 = SvPV(sv1, cur1);
4146 pv2 = SvPV(sv2, cur2);
4148 /* do not utf8ize the comparands as a side-effect */
4149 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4151 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4155 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4161 cmp = cur2 ? -1 : 0;
4165 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4168 cmp = retval < 0 ? -1 : 1;
4169 } else if (cur1 == cur2) {
4172 cmp = cur1 < cur2 ? -1 : 1;
4185 =for apidoc sv_cmp_locale
4187 Compares the strings in two SVs in a locale-aware manner. See
4194 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4196 #ifdef USE_LOCALE_COLLATE
4202 if (PL_collation_standard)
4206 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4208 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4210 if (!pv1 || !len1) {
4221 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4224 return retval < 0 ? -1 : 1;
4227 * When the result of collation is equality, that doesn't mean
4228 * that there are no differences -- some locales exclude some
4229 * characters from consideration. So to avoid false equalities,
4230 * we use the raw string as a tiebreaker.
4236 #endif /* USE_LOCALE_COLLATE */
4238 return sv_cmp(sv1, sv2);
4241 #ifdef USE_LOCALE_COLLATE
4243 * Any scalar variable may carry an 'o' magic that contains the
4244 * scalar data of the variable transformed to such a format that
4245 * a normal memory comparison can be used to compare the data
4246 * according to the locale settings.
4249 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4253 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4254 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4259 Safefree(mg->mg_ptr);
4261 if ((xf = mem_collxfrm(s, len, &xlen))) {
4262 if (SvREADONLY(sv)) {
4265 return xf + sizeof(PL_collation_ix);
4268 sv_magic(sv, 0, 'o', 0, 0);
4269 mg = mg_find(sv, 'o');
4282 if (mg && mg->mg_ptr) {
4284 return mg->mg_ptr + sizeof(PL_collation_ix);
4292 #endif /* USE_LOCALE_COLLATE */
4297 Get a line from the filehandle and store it into the SV, optionally
4298 appending to the currently-stored string.
4304 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4309 register STDCHAR rslast;
4310 register STDCHAR *bp;
4314 SV_CHECK_THINKFIRST(sv);
4315 (void)SvUPGRADE(sv, SVt_PV);
4319 if (RsSNARF(PL_rs)) {
4323 else if (RsRECORD(PL_rs)) {
4324 I32 recsize, bytesread;
4327 /* Grab the size of the record we're getting */
4328 recsize = SvIV(SvRV(PL_rs));
4329 (void)SvPOK_only(sv); /* Validate pointer */
4330 buffer = SvGROW(sv, recsize + 1);
4333 /* VMS wants read instead of fread, because fread doesn't respect */
4334 /* RMS record boundaries. This is not necessarily a good thing to be */
4335 /* doing, but we've got no other real choice */
4336 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4338 bytesread = PerlIO_read(fp, buffer, recsize);
4340 SvCUR_set(sv, bytesread);
4341 buffer[bytesread] = '\0';
4342 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4344 else if (RsPARA(PL_rs)) {
4349 rsptr = SvPV(PL_rs, rslen);
4350 rslast = rslen ? rsptr[rslen - 1] : '\0';
4352 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4353 do { /* to make sure file boundaries work right */
4356 i = PerlIO_getc(fp);
4360 PerlIO_ungetc(fp,i);
4366 /* See if we know enough about I/O mechanism to cheat it ! */
4368 /* This used to be #ifdef test - it is made run-time test for ease
4369 of abstracting out stdio interface. One call should be cheap
4370 enough here - and may even be a macro allowing compile
4374 if (PerlIO_fast_gets(fp)) {
4377 * We're going to steal some values from the stdio struct
4378 * and put EVERYTHING in the innermost loop into registers.
4380 register STDCHAR *ptr;
4384 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4385 /* An ungetc()d char is handled separately from the regular
4386 * buffer, so we getc() it back out and stuff it in the buffer.
4388 i = PerlIO_getc(fp);
4389 if (i == EOF) return 0;
4390 *(--((*fp)->_ptr)) = (unsigned char) i;
4394 /* Here is some breathtakingly efficient cheating */
4396 cnt = PerlIO_get_cnt(fp); /* get count into register */
4397 (void)SvPOK_only(sv); /* validate pointer */
4398 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4399 if (cnt > 80 && SvLEN(sv) > append) {
4400 shortbuffered = cnt - SvLEN(sv) + append + 1;
4401 cnt -= shortbuffered;
4405 /* remember that cnt can be negative */
4406 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4411 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4412 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4413 DEBUG_P(PerlIO_printf(Perl_debug_log,
4414 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4415 DEBUG_P(PerlIO_printf(Perl_debug_log,
4416 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4417 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4418 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4423 while (cnt > 0) { /* this | eat */
4425 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4426 goto thats_all_folks; /* screams | sed :-) */
4430 Copy(ptr, bp, cnt, char); /* this | eat */
4431 bp += cnt; /* screams | dust */
4432 ptr += cnt; /* louder | sed :-) */
4437 if (shortbuffered) { /* oh well, must extend */
4438 cnt = shortbuffered;
4440 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4442 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4443 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4447 DEBUG_P(PerlIO_printf(Perl_debug_log,
4448 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4449 PTR2UV(ptr),(long)cnt));
4450 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4451 DEBUG_P(PerlIO_printf(Perl_debug_log,
4452 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4453 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4454 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4455 /* This used to call 'filbuf' in stdio form, but as that behaves like
4456 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4457 another abstraction. */
4458 i = PerlIO_getc(fp); /* get more characters */
4459 DEBUG_P(PerlIO_printf(Perl_debug_log,
4460 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4461 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4462 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4463 cnt = PerlIO_get_cnt(fp);
4464 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4465 DEBUG_P(PerlIO_printf(Perl_debug_log,
4466 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4468 if (i == EOF) /* all done for ever? */
4469 goto thats_really_all_folks;
4471 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4473 SvGROW(sv, bpx + cnt + 2);
4474 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4476 *bp++ = i; /* store character from PerlIO_getc */
4478 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
4479 goto thats_all_folks;
4483 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
4484 memNE((char*)bp - rslen, rsptr, rslen))
4485 goto screamer; /* go back to the fray */
4486 thats_really_all_folks:
4488 cnt += shortbuffered;
4489 DEBUG_P(PerlIO_printf(Perl_debug_log,
4490 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4491 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
4492 DEBUG_P(PerlIO_printf(Perl_debug_log,
4493 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4494 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4495 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4497 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
4498 DEBUG_P(PerlIO_printf(Perl_debug_log,
4499 "Screamer: done, len=%ld, string=|%.*s|\n",
4500 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
4505 /*The big, slow, and stupid way */
4508 /* Need to work around EPOC SDK features */
4509 /* On WINS: MS VC5 generates calls to _chkstk, */
4510 /* if a `large' stack frame is allocated */
4511 /* gcc on MARM does not generate calls like these */
4517 register STDCHAR *bpe = buf + sizeof(buf);
4519 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
4520 ; /* keep reading */
4524 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
4525 /* Accomodate broken VAXC compiler, which applies U8 cast to
4526 * both args of ?: operator, causing EOF to change into 255
4528 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
4532 sv_catpvn(sv, (char *) buf, cnt);
4534 sv_setpvn(sv, (char *) buf, cnt);
4536 if (i != EOF && /* joy */
4538 SvCUR(sv) < rslen ||
4539 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
4543 * If we're reading from a TTY and we get a short read,
4544 * indicating that the user hit his EOF character, we need
4545 * to notice it now, because if we try to read from the TTY
4546 * again, the EOF condition will disappear.
4548 * The comparison of cnt to sizeof(buf) is an optimization
4549 * that prevents unnecessary calls to feof().
4553 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
4558 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4559 while (i != EOF) { /* to make sure file boundaries work right */
4560 i = PerlIO_getc(fp);
4562 PerlIO_ungetc(fp,i);
4568 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
4575 Auto-increment of the value in the SV.
4581 Perl_sv_inc(pTHX_ register SV *sv)
4590 if (SvTHINKFIRST(sv)) {
4591 if (SvREADONLY(sv)) {
4593 if (PL_curcop != &PL_compiling)
4594 Perl_croak(aTHX_ PL_no_modify);
4598 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
4600 i = PTR2IV(SvRV(sv));
4605 flags = SvFLAGS(sv);
4606 if (flags & SVp_NOK) {
4607 (void)SvNOK_only(sv);
4611 if (flags & SVp_IOK) {
4613 if (SvUVX(sv) == UV_MAX)
4614 sv_setnv(sv, (NV)UV_MAX + 1.0);
4616 (void)SvIOK_only_UV(sv);
4619 if (SvIVX(sv) == IV_MAX)
4620 sv_setnv(sv, (NV)IV_MAX + 1.0);
4622 (void)SvIOK_only(sv);
4628 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
4629 if ((flags & SVTYPEMASK) < SVt_PVNV)
4630 sv_upgrade(sv, SVt_NV);
4632 (void)SvNOK_only(sv);
4636 while (isALPHA(*d)) d++;
4637 while (isDIGIT(*d)) d++;
4639 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0); /* punt */
4643 while (d >= SvPVX(sv)) {
4651 /* MKS: The original code here died if letters weren't consecutive.
4652 * at least it didn't have to worry about non-C locales. The
4653 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
4654 * arranged in order (although not consecutively) and that only
4655 * [A-Za-z] are accepted by isALPHA in the C locale.
4657 if (*d != 'z' && *d != 'Z') {
4658 do { ++*d; } while (!isALPHA(*d));
4661 *(d--) -= 'z' - 'a';
4666 *(d--) -= 'z' - 'a' + 1;
4670 /* oh,oh, the number grew */
4671 SvGROW(sv, SvCUR(sv) + 2);
4673 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
4684 Auto-decrement of the value in the SV.
4690 Perl_sv_dec(pTHX_ register SV *sv)
4698 if (SvTHINKFIRST(sv)) {
4699 if (SvREADONLY(sv)) {
4701 if (PL_curcop != &PL_compiling)
4702 Perl_croak(aTHX_ PL_no_modify);
4706 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
4708 i = PTR2IV(SvRV(sv));
4713 flags = SvFLAGS(sv);
4714 if (flags & SVp_NOK) {
4716 (void)SvNOK_only(sv);
4719 if (flags & SVp_IOK) {
4721 if (SvUVX(sv) == 0) {
4722 (void)SvIOK_only(sv);
4726 (void)SvIOK_only_UV(sv);
4730 if (SvIVX(sv) == IV_MIN)
4731 sv_setnv(sv, (NV)IV_MIN - 1.0);
4733 (void)SvIOK_only(sv);
4739 if (!(flags & SVp_POK)) {
4740 if ((flags & SVTYPEMASK) < SVt_PVNV)
4741 sv_upgrade(sv, SVt_NV);
4743 (void)SvNOK_only(sv);
4746 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
4750 =for apidoc sv_mortalcopy
4752 Creates a new SV which is a copy of the original SV. The new SV is marked
4758 /* Make a string that will exist for the duration of the expression
4759 * evaluation. Actually, it may have to last longer than that, but
4760 * hopefully we won't free it until it has been assigned to a
4761 * permanent location. */
4764 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
4770 sv_setsv(sv,oldstr);
4772 PL_tmps_stack[++PL_tmps_ix] = sv;
4778 =for apidoc sv_newmortal
4780 Creates a new SV which is mortal. The reference count of the SV is set to 1.
4786 Perl_sv_newmortal(pTHX)
4792 SvFLAGS(sv) = SVs_TEMP;
4794 PL_tmps_stack[++PL_tmps_ix] = sv;
4799 =for apidoc sv_2mortal
4801 Marks an SV as mortal. The SV will be destroyed when the current context
4807 /* same thing without the copying */
4810 Perl_sv_2mortal(pTHX_ register SV *sv)
4815 if (SvREADONLY(sv) && SvIMMORTAL(sv))
4818 PL_tmps_stack[++PL_tmps_ix] = sv;
4826 Creates a new SV and copies a string into it. The reference count for the
4827 SV is set to 1. If C<len> is zero, Perl will compute the length using
4828 strlen(). For efficiency, consider using C<newSVpvn> instead.
4834 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
4841 sv_setpvn(sv,s,len);
4846 =for apidoc newSVpvn
4848 Creates a new SV and copies a string into it. The reference count for the
4849 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
4850 string. You are responsible for ensuring that the source string is at least
4857 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
4862 sv_setpvn(sv,s,len);
4867 =for apidoc newSVpvn_share
4869 Creates a new SV and populates it with a string from
4870 the string table. Turns on READONLY and FAKE.
4871 The idea here is that as string table is used for shared hash
4872 keys these strings will have SvPVX == HeKEY and hash lookup
4873 will avoid string compare.
4879 Perl_newSVpvn_share(pTHX_ const char *src, STRLEN len, U32 hash)
4883 PERL_HASH(hash, src, len);
4885 sv_upgrade(sv, SVt_PVIV);
4886 SvPVX(sv) = sharepvn(src, len, hash);
4896 #if defined(PERL_IMPLICIT_CONTEXT)
4898 Perl_newSVpvf_nocontext(const char* pat, ...)
4903 va_start(args, pat);
4904 sv = vnewSVpvf(pat, &args);
4911 =for apidoc newSVpvf
4913 Creates a new SV an initialize it with the string formatted like
4920 Perl_newSVpvf(pTHX_ const char* pat, ...)
4924 va_start(args, pat);
4925 sv = vnewSVpvf(pat, &args);
4931 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
4935 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
4942 Creates a new SV and copies a floating point value into it.
4943 The reference count for the SV is set to 1.
4949 Perl_newSVnv(pTHX_ NV n)
4961 Creates a new SV and copies an integer into it. The reference count for the
4968 Perl_newSViv(pTHX_ IV i)
4980 Creates a new SV and copies an unsigned integer into it.
4981 The reference count for the SV is set to 1.
4987 Perl_newSVuv(pTHX_ UV u)
4997 =for apidoc newRV_noinc
4999 Creates an RV wrapper for an SV. The reference count for the original
5000 SV is B<not> incremented.
5006 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5012 sv_upgrade(sv, SVt_RV);
5019 /* newRV_inc is #defined to newRV in sv.h */
5021 Perl_newRV(pTHX_ SV *tmpRef)
5023 return newRV_noinc(SvREFCNT_inc(tmpRef));
5029 Creates a new SV which is an exact duplicate of the original SV.
5034 /* make an exact duplicate of old */
5037 Perl_newSVsv(pTHX_ register SV *old)
5044 if (SvTYPE(old) == SVTYPEMASK) {
5045 if (ckWARN_d(WARN_INTERNAL))
5046 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5061 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5069 char todo[PERL_UCHAR_MAX+1];
5074 if (!*s) { /* reset ?? searches */
5075 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5076 pm->op_pmdynflags &= ~PMdf_USED;
5081 /* reset variables */
5083 if (!HvARRAY(stash))
5086 Zero(todo, 256, char);
5088 i = (unsigned char)*s;
5092 max = (unsigned char)*s++;
5093 for ( ; i <= max; i++) {
5096 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5097 for (entry = HvARRAY(stash)[i];
5099 entry = HeNEXT(entry))
5101 if (!todo[(U8)*HeKEY(entry)])
5103 gv = (GV*)HeVAL(entry);
5105 if (SvTHINKFIRST(sv)) {
5106 if (!SvREADONLY(sv) && SvROK(sv))
5111 if (SvTYPE(sv) >= SVt_PV) {
5113 if (SvPVX(sv) != Nullch)
5120 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5122 #ifndef VMS /* VMS has no environ array */
5124 environ[0] = Nullch;
5133 Perl_sv_2io(pTHX_ SV *sv)
5139 switch (SvTYPE(sv)) {
5147 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5151 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5153 return sv_2io(SvRV(sv));
5154 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5160 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5167 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5174 return *gvp = Nullgv, Nullcv;
5175 switch (SvTYPE(sv)) {
5195 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5196 tryAMAGICunDEREF(to_cv);
5199 if (SvTYPE(sv) == SVt_PVCV) {
5208 Perl_croak(aTHX_ "Not a subroutine reference");
5213 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5219 if (lref && !GvCVu(gv)) {
5222 tmpsv = NEWSV(704,0);
5223 gv_efullname3(tmpsv, gv, Nullch);
5224 /* XXX this is probably not what they think they're getting.
5225 * It has the same effect as "sub name;", i.e. just a forward
5227 newSUB(start_subparse(FALSE, 0),
5228 newSVOP(OP_CONST, 0, tmpsv),
5233 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5242 Returns true if the SV has a true value by Perl's rules.
5248 Perl_sv_true(pTHX_ register SV *sv)
5255 if ((tXpv = (XPV*)SvANY(sv)) &&
5256 (tXpv->xpv_cur > 1 ||
5257 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5264 return SvIVX(sv) != 0;
5267 return SvNVX(sv) != 0.0;
5269 return sv_2bool(sv);
5275 Perl_sv_iv(pTHX_ register SV *sv)
5279 return (IV)SvUVX(sv);
5286 Perl_sv_uv(pTHX_ register SV *sv)
5291 return (UV)SvIVX(sv);
5297 Perl_sv_nv(pTHX_ register SV *sv)
5305 Perl_sv_pv(pTHX_ SV *sv)
5312 return sv_2pv(sv, &n_a);
5316 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5322 return sv_2pv(sv, lp);
5326 =for apidoc sv_pvn_force
5328 Get a sensible string out of the SV somehow.
5334 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5338 if (SvTHINKFIRST(sv) && !SvROK(sv))
5339 sv_force_normal(sv);
5345 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5347 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5348 PL_op_name[PL_op->op_type]);
5352 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5357 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5358 SvGROW(sv, len + 1);
5359 Move(s,SvPVX(sv),len,char);
5364 SvPOK_on(sv); /* validate pointer */
5366 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5367 PTR2UV(sv),SvPVX(sv)));
5374 Perl_sv_pvbyte(pTHX_ SV *sv)
5380 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5382 return sv_pvn(sv,lp);
5386 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5388 return sv_pvn_force(sv,lp);
5392 Perl_sv_pvutf8(pTHX_ SV *sv)
5394 sv_utf8_upgrade(sv);
5399 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
5401 sv_utf8_upgrade(sv);
5402 return sv_pvn(sv,lp);
5406 =for apidoc sv_pvutf8n_force
5408 Get a sensible UTF8-encoded string out of the SV somehow. See
5415 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
5417 sv_utf8_upgrade(sv);
5418 return sv_pvn_force(sv,lp);
5422 =for apidoc sv_reftype
5424 Returns a string describing what the SV is a reference to.
5430 Perl_sv_reftype(pTHX_ SV *sv, int ob)
5432 if (ob && SvOBJECT(sv))
5433 return HvNAME(SvSTASH(sv));
5435 switch (SvTYPE(sv)) {
5449 case SVt_PVLV: return "LVALUE";
5450 case SVt_PVAV: return "ARRAY";
5451 case SVt_PVHV: return "HASH";
5452 case SVt_PVCV: return "CODE";
5453 case SVt_PVGV: return "GLOB";
5454 case SVt_PVFM: return "FORMAT";
5455 case SVt_PVIO: return "IO";
5456 default: return "UNKNOWN";
5462 =for apidoc sv_isobject
5464 Returns a boolean indicating whether the SV is an RV pointing to a blessed
5465 object. If the SV is not an RV, or if the object is not blessed, then this
5472 Perl_sv_isobject(pTHX_ SV *sv)
5489 Returns a boolean indicating whether the SV is blessed into the specified
5490 class. This does not check for subtypes; use C<sv_derived_from> to verify
5491 an inheritance relationship.
5497 Perl_sv_isa(pTHX_ SV *sv, const char *name)
5509 return strEQ(HvNAME(SvSTASH(sv)), name);
5515 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
5516 it will be upgraded to one. If C<classname> is non-null then the new SV will
5517 be blessed in the specified package. The new SV is returned and its
5518 reference count is 1.
5524 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
5531 SV_CHECK_THINKFIRST(rv);
5534 if (SvTYPE(rv) >= SVt_PVMG) {
5535 U32 refcnt = SvREFCNT(rv);
5539 SvREFCNT(rv) = refcnt;
5542 if (SvTYPE(rv) < SVt_RV)
5543 sv_upgrade(rv, SVt_RV);
5544 else if (SvTYPE(rv) > SVt_RV) {
5545 (void)SvOOK_off(rv);
5546 if (SvPVX(rv) && SvLEN(rv))
5547 Safefree(SvPVX(rv));
5557 HV* stash = gv_stashpv(classname, TRUE);
5558 (void)sv_bless(rv, stash);
5564 =for apidoc sv_setref_pv
5566 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
5567 argument will be upgraded to an RV. That RV will be modified to point to
5568 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
5569 into the SV. The C<classname> argument indicates the package for the
5570 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5571 will be returned and will have a reference count of 1.
5573 Do not use with other Perl types such as HV, AV, SV, CV, because those
5574 objects will become corrupted by the pointer copy process.
5576 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
5582 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
5585 sv_setsv(rv, &PL_sv_undef);
5589 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
5594 =for apidoc sv_setref_iv
5596 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
5597 argument will be upgraded to an RV. That RV will be modified to point to
5598 the new SV. The C<classname> argument indicates the package for the
5599 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5600 will be returned and will have a reference count of 1.
5606 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
5608 sv_setiv(newSVrv(rv,classname), iv);
5613 =for apidoc sv_setref_nv
5615 Copies a double into a new SV, optionally blessing the SV. The C<rv>
5616 argument will be upgraded to an RV. That RV will be modified to point to
5617 the new SV. The C<classname> argument indicates the package for the
5618 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
5619 will be returned and will have a reference count of 1.
5625 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
5627 sv_setnv(newSVrv(rv,classname), nv);
5632 =for apidoc sv_setref_pvn
5634 Copies a string into a new SV, optionally blessing the SV. The length of the
5635 string must be specified with C<n>. The C<rv> argument will be upgraded to
5636 an RV. That RV will be modified to point to the new SV. The C<classname>
5637 argument indicates the package for the blessing. Set C<classname> to
5638 C<Nullch> to avoid the blessing. The new SV will be returned and will have
5639 a reference count of 1.
5641 Note that C<sv_setref_pv> copies the pointer while this copies the string.
5647 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
5649 sv_setpvn(newSVrv(rv,classname), pv, n);
5654 =for apidoc sv_bless
5656 Blesses an SV into a specified package. The SV must be an RV. The package
5657 must be designated by its stash (see C<gv_stashpv()>). The reference count
5658 of the SV is unaffected.
5664 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
5669 Perl_croak(aTHX_ "Can't bless non-reference value");
5671 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
5672 if (SvREADONLY(tmpRef))
5673 Perl_croak(aTHX_ PL_no_modify);
5674 if (SvOBJECT(tmpRef)) {
5675 if (SvTYPE(tmpRef) != SVt_PVIO)
5677 SvREFCNT_dec(SvSTASH(tmpRef));
5680 SvOBJECT_on(tmpRef);
5681 if (SvTYPE(tmpRef) != SVt_PVIO)
5683 (void)SvUPGRADE(tmpRef, SVt_PVMG);
5684 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
5695 S_sv_unglob(pTHX_ SV *sv)
5699 assert(SvTYPE(sv) == SVt_PVGV);
5704 SvREFCNT_dec(GvSTASH(sv));
5705 GvSTASH(sv) = Nullhv;
5707 sv_unmagic(sv, '*');
5708 Safefree(GvNAME(sv));
5711 /* need to keep SvANY(sv) in the right arena */
5712 xpvmg = new_XPVMG();
5713 StructCopy(SvANY(sv), xpvmg, XPVMG);
5714 del_XPVGV(SvANY(sv));
5717 SvFLAGS(sv) &= ~SVTYPEMASK;
5718 SvFLAGS(sv) |= SVt_PVMG;
5722 =for apidoc sv_unref
5724 Unsets the RV status of the SV, and decrements the reference count of
5725 whatever was being referenced by the RV. This can almost be thought of
5726 as a reversal of C<newSVrv>. See C<SvROK_off>.
5732 Perl_sv_unref(pTHX_ SV *sv)
5736 if (SvWEAKREF(sv)) {
5744 if (SvREFCNT(rv) != 1 || SvREADONLY(rv))
5747 sv_2mortal(rv); /* Schedule for freeing later */
5751 Perl_sv_taint(pTHX_ SV *sv)
5753 sv_magic((sv), Nullsv, 't', Nullch, 0);
5757 Perl_sv_untaint(pTHX_ SV *sv)
5759 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5760 MAGIC *mg = mg_find(sv, 't');
5767 Perl_sv_tainted(pTHX_ SV *sv)
5769 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
5770 MAGIC *mg = mg_find(sv, 't');
5771 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
5778 =for apidoc sv_setpviv
5780 Copies an integer into the given SV, also updating its string value.
5781 Does not handle 'set' magic. See C<sv_setpviv_mg>.
5787 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
5789 char buf[TYPE_CHARS(UV)];
5791 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5793 sv_setpvn(sv, ptr, ebuf - ptr);
5798 =for apidoc sv_setpviv_mg
5800 Like C<sv_setpviv>, but also handles 'set' magic.
5806 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
5808 char buf[TYPE_CHARS(UV)];
5810 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
5812 sv_setpvn(sv, ptr, ebuf - ptr);
5816 #if defined(PERL_IMPLICIT_CONTEXT)
5818 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
5822 va_start(args, pat);
5823 sv_vsetpvf(sv, pat, &args);
5829 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
5833 va_start(args, pat);
5834 sv_vsetpvf_mg(sv, pat, &args);
5840 =for apidoc sv_setpvf
5842 Processes its arguments like C<sprintf> and sets an SV to the formatted
5843 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
5849 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
5852 va_start(args, pat);
5853 sv_vsetpvf(sv, pat, &args);
5858 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5860 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5864 =for apidoc sv_setpvf_mg
5866 Like C<sv_setpvf>, but also handles 'set' magic.
5872 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5875 va_start(args, pat);
5876 sv_vsetpvf_mg(sv, pat, &args);
5881 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5883 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5887 #if defined(PERL_IMPLICIT_CONTEXT)
5889 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
5893 va_start(args, pat);
5894 sv_vcatpvf(sv, pat, &args);
5899 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
5903 va_start(args, pat);
5904 sv_vcatpvf_mg(sv, pat, &args);
5910 =for apidoc sv_catpvf
5912 Processes its arguments like C<sprintf> and appends the formatted output
5913 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
5914 typically be called after calling this function to handle 'set' magic.
5920 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
5923 va_start(args, pat);
5924 sv_vcatpvf(sv, pat, &args);
5929 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
5931 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5935 =for apidoc sv_catpvf_mg
5937 Like C<sv_catpvf>, but also handles 'set' magic.
5943 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
5946 va_start(args, pat);
5947 sv_vcatpvf_mg(sv, pat, &args);
5952 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
5954 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5959 =for apidoc sv_vsetpvfn
5961 Works like C<vcatpvfn> but copies the text into the SV instead of
5968 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5970 sv_setpvn(sv, "", 0);
5971 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
5975 =for apidoc sv_vcatpvfn
5977 Processes its arguments like C<vsprintf> and appends the formatted output
5978 to an SV. Uses an array of SVs if the C style variable argument list is
5979 missing (NULL). When running with taint checks enabled, indicates via
5980 C<maybe_tainted> if results are untrustworthy (often due to the use of
5987 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
5995 static char nullstr[] = "(null)";
5998 /* no matter what, this is a string now */
5999 (void)SvPV_force(sv, origlen);
6001 /* special-case "", "%s", and "%_" */
6004 if (patlen == 2 && pat[0] == '%') {
6008 char *s = va_arg(*args, char*);
6009 sv_catpv(sv, s ? s : nullstr);
6011 else if (svix < svmax) {
6012 sv_catsv(sv, *svargs);
6013 if (DO_UTF8(*svargs))
6019 argsv = va_arg(*args, SV*);
6020 sv_catsv(sv, argsv);
6025 /* See comment on '_' below */
6030 patend = (char*)pat + patlen;
6031 for (p = (char*)pat; p < patend; p = q) {
6034 bool vectorize = FALSE;
6041 bool has_precis = FALSE;
6043 bool is_utf = FALSE;
6046 U8 utf8buf[UTF8_MAXLEN];
6047 STRLEN esignlen = 0;
6049 char *eptr = Nullch;
6051 /* Times 4: a decimal digit takes more than 3 binary digits.
6052 * NV_DIG: mantissa takes than many decimal digits.
6053 * Plus 32: Playing safe. */
6054 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6055 /* large enough for "%#.#f" --chip */
6056 /* what about long double NVs? --jhi */
6059 U8 *vecstr = Null(U8*);
6071 STRLEN dotstrlen = 1;
6073 for (q = p; q < patend && *q != '%'; ++q) ;
6075 sv_catpvn(sv, p, q - p);
6104 case '*': /* printf("%*vX",":",$ipv6addr) */
6109 vecsv = va_arg(*args, SV*);
6110 else if (svix < svmax)
6111 vecsv = svargs[svix++];
6114 dotstr = SvPVx(vecsv,dotstrlen);
6133 case '1': case '2': case '3':
6134 case '4': case '5': case '6':
6135 case '7': case '8': case '9':
6138 width = width * 10 + (*q++ - '0');
6143 i = va_arg(*args, int);
6145 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6147 width = (i < 0) ? -i : i;
6158 i = va_arg(*args, int);
6160 i = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6161 precis = (i < 0) ? 0 : i;
6167 precis = precis * 10 + (*q++ - '0');
6174 vecsv = va_arg(*args, SV*);
6175 vecstr = (U8*)SvPVx(vecsv,veclen);
6176 utf = DO_UTF8(vecsv);
6178 else if (svix < svmax) {
6179 vecsv = svargs[svix++];
6180 vecstr = (U8*)SvPVx(vecsv,veclen);
6181 utf = DO_UTF8(vecsv);
6192 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6203 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6204 if (*(q + 1) == 'l') { /* lld, llf */
6231 uv = va_arg(*args, int);
6233 uv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6234 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6235 eptr = (char*)utf8buf;
6236 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6248 eptr = va_arg(*args, char*);
6250 #ifdef MACOS_TRADITIONAL
6251 /* On MacOS, %#s format is used for Pascal strings */
6256 elen = strlen(eptr);
6259 elen = sizeof nullstr - 1;
6262 else if (svix < svmax) {
6263 argsv = svargs[svix++];
6264 eptr = SvPVx(argsv, elen);
6265 if (DO_UTF8(argsv)) {
6266 if (has_precis && precis < elen) {
6268 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6271 if (width) { /* fudge width (can't fudge elen) */
6272 width += elen - sv_len_utf8(argsv);
6281 * The "%_" hack might have to be changed someday,
6282 * if ISO or ANSI decide to use '_' for something.
6283 * So we keep it hidden from users' code.
6287 argsv = va_arg(*args,SV*);
6288 eptr = SvPVx(argsv, elen);
6294 if (has_precis && elen > precis)
6304 uv = PTR2UV(va_arg(*args, void*));
6306 uv = (svix < svmax) ? PTR2UV(svargs[svix++]) : 0;
6326 iv = (IV)utf8_to_uv_chk(vecstr, &ulen, 0);
6336 case 'h': iv = (short)va_arg(*args, int); break;
6337 default: iv = va_arg(*args, int); break;
6338 case 'l': iv = va_arg(*args, long); break;
6339 case 'V': iv = va_arg(*args, IV); break;
6341 case 'q': iv = va_arg(*args, Quad_t); break;
6346 iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0;
6348 case 'h': iv = (short)iv; break;
6350 case 'l': iv = (long)iv; break;
6353 case 'q': iv = (Quad_t)iv; break;
6360 esignbuf[esignlen++] = plus;
6364 esignbuf[esignlen++] = '-';
6408 uv = utf8_to_uv_chk(vecstr, &ulen, 0);
6418 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
6419 default: uv = va_arg(*args, unsigned); break;
6420 case 'l': uv = va_arg(*args, unsigned long); break;
6421 case 'V': uv = va_arg(*args, UV); break;
6423 case 'q': uv = va_arg(*args, Quad_t); break;
6428 uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0;
6430 case 'h': uv = (unsigned short)uv; break;
6432 case 'l': uv = (unsigned long)uv; break;
6435 case 'q': uv = (Quad_t)uv; break;
6441 eptr = ebuf + sizeof ebuf;
6447 p = (char*)((c == 'X')
6448 ? "0123456789ABCDEF" : "0123456789abcdef");
6454 esignbuf[esignlen++] = '0';
6455 esignbuf[esignlen++] = c; /* 'x' or 'X' */
6461 *--eptr = '0' + dig;
6463 if (alt && *eptr != '0')
6469 *--eptr = '0' + dig;
6472 esignbuf[esignlen++] = '0';
6473 esignbuf[esignlen++] = 'b';
6476 default: /* it had better be ten or less */
6477 #if defined(PERL_Y2KWARN)
6478 if (ckWARN(WARN_Y2K)) {
6480 char *s = SvPV(sv,n);
6481 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
6482 && (n == 2 || !isDIGIT(s[n-3])))
6484 Perl_warner(aTHX_ WARN_Y2K,
6485 "Possible Y2K bug: %%%c %s",
6486 c, "format string following '19'");
6492 *--eptr = '0' + dig;
6493 } while (uv /= base);
6496 elen = (ebuf + sizeof ebuf) - eptr;
6499 zeros = precis - elen;
6500 else if (precis == 0 && elen == 1 && *eptr == '0')
6505 /* FLOATING POINT */
6508 c = 'f'; /* maybe %F isn't supported here */
6514 /* This is evil, but floating point is even more evil */
6518 nv = va_arg(*args, NV);
6520 nv = (svix < svmax) ? SvNVx(svargs[svix++]) : 0.0;
6523 if (c != 'e' && c != 'E') {
6525 (void)Perl_frexp(nv, &i);
6526 if (i == PERL_INT_MIN)
6527 Perl_die(aTHX_ "panic: frexp");
6529 need = BIT_DIGITS(i);
6531 need += has_precis ? precis : 6; /* known default */
6535 need += 20; /* fudge factor */
6536 if (PL_efloatsize < need) {
6537 Safefree(PL_efloatbuf);
6538 PL_efloatsize = need + 20; /* more fudge */
6539 New(906, PL_efloatbuf, PL_efloatsize, char);
6540 PL_efloatbuf[0] = '\0';
6543 eptr = ebuf + sizeof ebuf;
6546 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
6548 /* Copy the one or more characters in a long double
6549 * format before the 'base' ([efgEFG]) character to
6550 * the format string. */
6551 static char const prifldbl[] = PERL_PRIfldbl;
6552 char const *p = prifldbl + sizeof(prifldbl) - 3;
6553 while (p >= prifldbl) { *--eptr = *p--; }
6558 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6563 do { *--eptr = '0' + (base % 10); } while (base /= 10);
6576 STORE_NUMERIC_STANDARD_SET_LOCAL();
6577 #ifdef USE_LOCALE_NUMERIC
6578 if (!was_standard && maybe_tainted)
6579 *maybe_tainted = TRUE;
6581 (void)sprintf(PL_efloatbuf, eptr, nv);
6582 RESTORE_NUMERIC_STANDARD();
6585 eptr = PL_efloatbuf;
6586 elen = strlen(PL_efloatbuf);
6593 i = SvCUR(sv) - origlen;
6596 case 'h': *(va_arg(*args, short*)) = i; break;
6597 default: *(va_arg(*args, int*)) = i; break;
6598 case 'l': *(va_arg(*args, long*)) = i; break;
6599 case 'V': *(va_arg(*args, IV*)) = i; break;
6601 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
6605 else if (svix < svmax)
6606 sv_setuv_mg(svargs[svix++], (UV)i);
6607 continue; /* not "break" */
6614 if (!args && ckWARN(WARN_PRINTF) &&
6615 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
6616 SV *msg = sv_newmortal();
6617 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
6618 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
6621 Perl_sv_catpvf(aTHX_ msg,
6622 "\"%%%c\"", c & 0xFF);
6624 Perl_sv_catpvf(aTHX_ msg,
6625 "\"%%\\%03"UVof"\"",
6628 sv_catpv(msg, "end of string");
6629 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
6632 /* output mangled stuff ... */
6638 /* ... right here, because formatting flags should not apply */
6639 SvGROW(sv, SvCUR(sv) + elen + 1);
6641 memcpy(p, eptr, elen);
6644 SvCUR(sv) = p - SvPVX(sv);
6645 continue; /* not "break" */
6648 have = esignlen + zeros + elen;
6649 need = (have > width ? have : width);
6652 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
6654 if (esignlen && fill == '0') {
6655 for (i = 0; i < esignlen; i++)
6659 memset(p, fill, gap);
6662 if (esignlen && fill != '0') {
6663 for (i = 0; i < esignlen; i++)
6667 for (i = zeros; i; i--)
6671 memcpy(p, eptr, elen);
6675 memset(p, ' ', gap);
6680 memcpy(p, dotstr, dotstrlen);
6684 vectorize = FALSE; /* done iterating over vecstr */
6689 SvCUR(sv) = p - SvPVX(sv);
6697 #if defined(USE_ITHREADS)
6699 #if defined(USE_THREADS)
6700 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
6703 #ifndef GpREFCNT_inc
6704 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
6708 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
6709 #define av_dup(s) (AV*)sv_dup((SV*)s)
6710 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
6711 #define hv_dup(s) (HV*)sv_dup((SV*)s)
6712 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
6713 #define cv_dup(s) (CV*)sv_dup((SV*)s)
6714 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
6715 #define io_dup(s) (IO*)sv_dup((SV*)s)
6716 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
6717 #define gv_dup(s) (GV*)sv_dup((SV*)s)
6718 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
6719 #define SAVEPV(p) (p ? savepv(p) : Nullch)
6720 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
6723 Perl_re_dup(pTHX_ REGEXP *r)
6725 /* XXX fix when pmop->op_pmregexp becomes shared */
6726 return ReREFCNT_inc(r);
6730 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
6734 return (PerlIO*)NULL;
6736 /* look for it in the table first */
6737 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
6741 /* create anew and remember what it is */
6742 ret = PerlIO_fdupopen(fp);
6743 ptr_table_store(PL_ptr_table, fp, ret);
6748 Perl_dirp_dup(pTHX_ DIR *dp)
6757 Perl_gp_dup(pTHX_ GP *gp)
6762 /* look for it in the table first */
6763 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
6767 /* create anew and remember what it is */
6768 Newz(0, ret, 1, GP);
6769 ptr_table_store(PL_ptr_table, gp, ret);
6772 ret->gp_refcnt = 0; /* must be before any other dups! */
6773 ret->gp_sv = sv_dup_inc(gp->gp_sv);
6774 ret->gp_io = io_dup_inc(gp->gp_io);
6775 ret->gp_form = cv_dup_inc(gp->gp_form);
6776 ret->gp_av = av_dup_inc(gp->gp_av);
6777 ret->gp_hv = hv_dup_inc(gp->gp_hv);
6778 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
6779 ret->gp_cv = cv_dup_inc(gp->gp_cv);
6780 ret->gp_cvgen = gp->gp_cvgen;
6781 ret->gp_flags = gp->gp_flags;
6782 ret->gp_line = gp->gp_line;
6783 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
6788 Perl_mg_dup(pTHX_ MAGIC *mg)
6790 MAGIC *mgret = (MAGIC*)NULL;
6793 return (MAGIC*)NULL;
6794 /* look for it in the table first */
6795 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
6799 for (; mg; mg = mg->mg_moremagic) {
6801 Newz(0, nmg, 1, MAGIC);
6805 mgprev->mg_moremagic = nmg;
6806 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
6807 nmg->mg_private = mg->mg_private;
6808 nmg->mg_type = mg->mg_type;
6809 nmg->mg_flags = mg->mg_flags;
6810 if (mg->mg_type == 'r') {
6811 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
6814 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
6815 ? sv_dup_inc(mg->mg_obj)
6816 : sv_dup(mg->mg_obj);
6818 nmg->mg_len = mg->mg_len;
6819 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
6820 if (mg->mg_ptr && mg->mg_type != 'g') {
6821 if (mg->mg_len >= 0) {
6822 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
6823 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
6824 AMT *amtp = (AMT*)mg->mg_ptr;
6825 AMT *namtp = (AMT*)nmg->mg_ptr;
6827 for (i = 1; i < NofAMmeth; i++) {
6828 namtp->table[i] = cv_dup_inc(amtp->table[i]);
6832 else if (mg->mg_len == HEf_SVKEY)
6833 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
6841 Perl_ptr_table_new(pTHX)
6844 Newz(0, tbl, 1, PTR_TBL_t);
6847 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
6852 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
6854 PTR_TBL_ENT_t *tblent;
6855 UV hash = PTR2UV(sv);
6857 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
6858 for (; tblent; tblent = tblent->next) {
6859 if (tblent->oldval == sv)
6860 return tblent->newval;
6866 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
6868 PTR_TBL_ENT_t *tblent, **otblent;
6869 /* XXX this may be pessimal on platforms where pointers aren't good
6870 * hash values e.g. if they grow faster in the most significant
6872 UV hash = PTR2UV(oldv);
6876 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
6877 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
6878 if (tblent->oldval == oldv) {
6879 tblent->newval = newv;
6884 Newz(0, tblent, 1, PTR_TBL_ENT_t);
6885 tblent->oldval = oldv;
6886 tblent->newval = newv;
6887 tblent->next = *otblent;
6890 if (i && tbl->tbl_items > tbl->tbl_max)
6891 ptr_table_split(tbl);
6895 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
6897 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
6898 UV oldsize = tbl->tbl_max + 1;
6899 UV newsize = oldsize * 2;
6902 Renew(ary, newsize, PTR_TBL_ENT_t*);
6903 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
6904 tbl->tbl_max = --newsize;
6906 for (i=0; i < oldsize; i++, ary++) {
6907 PTR_TBL_ENT_t **curentp, **entp, *ent;
6910 curentp = ary + oldsize;
6911 for (entp = ary, ent = *ary; ent; ent = *entp) {
6912 if ((newsize & PTR2UV(ent->oldval)) != i) {
6914 ent->next = *curentp;
6929 Perl_sv_dup(pTHX_ SV *sstr)
6933 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
6935 /* look for it in the table first */
6936 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
6940 /* create anew and remember what it is */
6942 ptr_table_store(PL_ptr_table, sstr, dstr);
6945 SvFLAGS(dstr) = SvFLAGS(sstr);
6946 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
6947 SvREFCNT(dstr) = 0; /* must be before any other dups! */
6950 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
6951 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
6952 PL_watch_pvx, SvPVX(sstr));
6955 switch (SvTYPE(sstr)) {
6960 SvANY(dstr) = new_XIV();
6961 SvIVX(dstr) = SvIVX(sstr);
6964 SvANY(dstr) = new_XNV();
6965 SvNVX(dstr) = SvNVX(sstr);
6968 SvANY(dstr) = new_XRV();
6969 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6972 SvANY(dstr) = new_XPV();
6973 SvCUR(dstr) = SvCUR(sstr);
6974 SvLEN(dstr) = SvLEN(sstr);
6976 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6977 else if (SvPVX(sstr) && SvLEN(sstr))
6978 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6980 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6983 SvANY(dstr) = new_XPVIV();
6984 SvCUR(dstr) = SvCUR(sstr);
6985 SvLEN(dstr) = SvLEN(sstr);
6986 SvIVX(dstr) = SvIVX(sstr);
6988 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
6989 else if (SvPVX(sstr) && SvLEN(sstr))
6990 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
6992 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
6995 SvANY(dstr) = new_XPVNV();
6996 SvCUR(dstr) = SvCUR(sstr);
6997 SvLEN(dstr) = SvLEN(sstr);
6998 SvIVX(dstr) = SvIVX(sstr);
6999 SvNVX(dstr) = SvNVX(sstr);
7001 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7002 else if (SvPVX(sstr) && SvLEN(sstr))
7003 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7005 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7008 SvANY(dstr) = new_XPVMG();
7009 SvCUR(dstr) = SvCUR(sstr);
7010 SvLEN(dstr) = SvLEN(sstr);
7011 SvIVX(dstr) = SvIVX(sstr);
7012 SvNVX(dstr) = SvNVX(sstr);
7013 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7014 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7016 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7017 else if (SvPVX(sstr) && SvLEN(sstr))
7018 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7020 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7023 SvANY(dstr) = new_XPVBM();
7024 SvCUR(dstr) = SvCUR(sstr);
7025 SvLEN(dstr) = SvLEN(sstr);
7026 SvIVX(dstr) = SvIVX(sstr);
7027 SvNVX(dstr) = SvNVX(sstr);
7028 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7029 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7031 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7032 else if (SvPVX(sstr) && SvLEN(sstr))
7033 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7035 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7036 BmRARE(dstr) = BmRARE(sstr);
7037 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7038 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7041 SvANY(dstr) = new_XPVLV();
7042 SvCUR(dstr) = SvCUR(sstr);
7043 SvLEN(dstr) = SvLEN(sstr);
7044 SvIVX(dstr) = SvIVX(sstr);
7045 SvNVX(dstr) = SvNVX(sstr);
7046 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7047 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7049 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7050 else if (SvPVX(sstr) && SvLEN(sstr))
7051 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7053 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7054 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7055 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7056 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7057 LvTYPE(dstr) = LvTYPE(sstr);
7060 SvANY(dstr) = new_XPVGV();
7061 SvCUR(dstr) = SvCUR(sstr);
7062 SvLEN(dstr) = SvLEN(sstr);
7063 SvIVX(dstr) = SvIVX(sstr);
7064 SvNVX(dstr) = SvNVX(sstr);
7065 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7066 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7068 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7069 else if (SvPVX(sstr) && SvLEN(sstr))
7070 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7072 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7073 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7074 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7075 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7076 GvFLAGS(dstr) = GvFLAGS(sstr);
7077 GvGP(dstr) = gp_dup(GvGP(sstr));
7078 (void)GpREFCNT_inc(GvGP(dstr));
7081 SvANY(dstr) = new_XPVIO();
7082 SvCUR(dstr) = SvCUR(sstr);
7083 SvLEN(dstr) = SvLEN(sstr);
7084 SvIVX(dstr) = SvIVX(sstr);
7085 SvNVX(dstr) = SvNVX(sstr);
7086 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7087 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7089 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7090 else if (SvPVX(sstr) && SvLEN(sstr))
7091 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7093 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7094 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7095 if (IoOFP(sstr) == IoIFP(sstr))
7096 IoOFP(dstr) = IoIFP(dstr);
7098 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7099 /* PL_rsfp_filters entries have fake IoDIRP() */
7100 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7101 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7103 IoDIRP(dstr) = IoDIRP(sstr);
7104 IoLINES(dstr) = IoLINES(sstr);
7105 IoPAGE(dstr) = IoPAGE(sstr);
7106 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7107 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7108 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7109 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7110 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7111 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7112 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7113 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7114 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7115 IoTYPE(dstr) = IoTYPE(sstr);
7116 IoFLAGS(dstr) = IoFLAGS(sstr);
7119 SvANY(dstr) = new_XPVAV();
7120 SvCUR(dstr) = SvCUR(sstr);
7121 SvLEN(dstr) = SvLEN(sstr);
7122 SvIVX(dstr) = SvIVX(sstr);
7123 SvNVX(dstr) = SvNVX(sstr);
7124 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7125 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7126 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7127 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7128 if (AvARRAY((AV*)sstr)) {
7129 SV **dst_ary, **src_ary;
7130 SSize_t items = AvFILLp((AV*)sstr) + 1;
7132 src_ary = AvARRAY((AV*)sstr);
7133 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7134 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7135 SvPVX(dstr) = (char*)dst_ary;
7136 AvALLOC((AV*)dstr) = dst_ary;
7137 if (AvREAL((AV*)sstr)) {
7139 *dst_ary++ = sv_dup_inc(*src_ary++);
7143 *dst_ary++ = sv_dup(*src_ary++);
7145 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7146 while (items-- > 0) {
7147 *dst_ary++ = &PL_sv_undef;
7151 SvPVX(dstr) = Nullch;
7152 AvALLOC((AV*)dstr) = (SV**)NULL;
7156 SvANY(dstr) = new_XPVHV();
7157 SvCUR(dstr) = SvCUR(sstr);
7158 SvLEN(dstr) = SvLEN(sstr);
7159 SvIVX(dstr) = SvIVX(sstr);
7160 SvNVX(dstr) = SvNVX(sstr);
7161 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7162 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7163 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7164 if (HvARRAY((HV*)sstr)) {
7166 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7167 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7168 Newz(0, dxhv->xhv_array,
7169 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7170 while (i <= sxhv->xhv_max) {
7171 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7172 !!HvSHAREKEYS(sstr));
7175 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7178 SvPVX(dstr) = Nullch;
7179 HvEITER((HV*)dstr) = (HE*)NULL;
7181 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7182 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7185 SvANY(dstr) = new_XPVFM();
7186 FmLINES(dstr) = FmLINES(sstr);
7190 SvANY(dstr) = new_XPVCV();
7192 SvCUR(dstr) = SvCUR(sstr);
7193 SvLEN(dstr) = SvLEN(sstr);
7194 SvIVX(dstr) = SvIVX(sstr);
7195 SvNVX(dstr) = SvNVX(sstr);
7196 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7197 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7198 if (SvPVX(sstr) && SvLEN(sstr))
7199 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7201 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7202 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7203 CvSTART(dstr) = CvSTART(sstr);
7204 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7205 CvXSUB(dstr) = CvXSUB(sstr);
7206 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7207 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7208 CvDEPTH(dstr) = CvDEPTH(sstr);
7209 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7210 /* XXX padlists are real, but pretend to be not */
7211 AvREAL_on(CvPADLIST(sstr));
7212 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7213 AvREAL_off(CvPADLIST(sstr));
7214 AvREAL_off(CvPADLIST(dstr));
7217 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7218 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7219 CvFLAGS(dstr) = CvFLAGS(sstr);
7222 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7226 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7233 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7238 return (PERL_CONTEXT*)NULL;
7240 /* look for it in the table first */
7241 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7245 /* create anew and remember what it is */
7246 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7247 ptr_table_store(PL_ptr_table, cxs, ncxs);
7250 PERL_CONTEXT *cx = &cxs[ix];
7251 PERL_CONTEXT *ncx = &ncxs[ix];
7252 ncx->cx_type = cx->cx_type;
7253 if (CxTYPE(cx) == CXt_SUBST) {
7254 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7257 ncx->blk_oldsp = cx->blk_oldsp;
7258 ncx->blk_oldcop = cx->blk_oldcop;
7259 ncx->blk_oldretsp = cx->blk_oldretsp;
7260 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7261 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7262 ncx->blk_oldpm = cx->blk_oldpm;
7263 ncx->blk_gimme = cx->blk_gimme;
7264 switch (CxTYPE(cx)) {
7266 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7267 ? cv_dup_inc(cx->blk_sub.cv)
7268 : cv_dup(cx->blk_sub.cv));
7269 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7270 ? av_dup_inc(cx->blk_sub.argarray)
7272 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7273 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7274 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7275 ncx->blk_sub.lval = cx->blk_sub.lval;
7278 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7279 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7280 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7281 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7282 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7285 ncx->blk_loop.label = cx->blk_loop.label;
7286 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7287 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7288 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7289 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7290 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7291 ? cx->blk_loop.iterdata
7292 : gv_dup((GV*)cx->blk_loop.iterdata));
7293 ncx->blk_loop.oldcurpad
7294 = (SV**)ptr_table_fetch(PL_ptr_table,
7295 cx->blk_loop.oldcurpad);
7296 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7297 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7298 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7299 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7300 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7303 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7304 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7305 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7306 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7319 Perl_si_dup(pTHX_ PERL_SI *si)
7324 return (PERL_SI*)NULL;
7326 /* look for it in the table first */
7327 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7331 /* create anew and remember what it is */
7332 Newz(56, nsi, 1, PERL_SI);
7333 ptr_table_store(PL_ptr_table, si, nsi);
7335 nsi->si_stack = av_dup_inc(si->si_stack);
7336 nsi->si_cxix = si->si_cxix;
7337 nsi->si_cxmax = si->si_cxmax;
7338 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7339 nsi->si_type = si->si_type;
7340 nsi->si_prev = si_dup(si->si_prev);
7341 nsi->si_next = si_dup(si->si_next);
7342 nsi->si_markoff = si->si_markoff;
7347 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
7348 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
7349 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
7350 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
7351 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
7352 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
7353 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
7354 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
7355 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
7356 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
7357 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
7358 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
7361 #define pv_dup_inc(p) SAVEPV(p)
7362 #define pv_dup(p) SAVEPV(p)
7363 #define svp_dup_inc(p,pp) any_dup(p,pp)
7366 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
7373 /* look for it in the table first */
7374 ret = ptr_table_fetch(PL_ptr_table, v);
7378 /* see if it is part of the interpreter structure */
7379 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
7380 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
7388 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
7390 ANY *ss = proto_perl->Tsavestack;
7391 I32 ix = proto_perl->Tsavestack_ix;
7392 I32 max = proto_perl->Tsavestack_max;
7405 void (*dptr) (void*);
7406 void (*dxptr) (pTHXo_ void*);
7409 Newz(54, nss, max, ANY);
7415 case SAVEt_ITEM: /* normal string */
7416 sv = (SV*)POPPTR(ss,ix);
7417 TOPPTR(nss,ix) = sv_dup_inc(sv);
7418 sv = (SV*)POPPTR(ss,ix);
7419 TOPPTR(nss,ix) = sv_dup_inc(sv);
7421 case SAVEt_SV: /* scalar reference */
7422 sv = (SV*)POPPTR(ss,ix);
7423 TOPPTR(nss,ix) = sv_dup_inc(sv);
7424 gv = (GV*)POPPTR(ss,ix);
7425 TOPPTR(nss,ix) = gv_dup_inc(gv);
7427 case SAVEt_GENERIC_PVREF: /* generic char* */
7428 c = (char*)POPPTR(ss,ix);
7429 TOPPTR(nss,ix) = pv_dup(c);
7430 ptr = POPPTR(ss,ix);
7431 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7433 case SAVEt_GENERIC_SVREF: /* generic sv */
7434 case SAVEt_SVREF: /* scalar reference */
7435 sv = (SV*)POPPTR(ss,ix);
7436 TOPPTR(nss,ix) = sv_dup_inc(sv);
7437 ptr = POPPTR(ss,ix);
7438 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
7440 case SAVEt_AV: /* array reference */
7441 av = (AV*)POPPTR(ss,ix);
7442 TOPPTR(nss,ix) = av_dup_inc(av);
7443 gv = (GV*)POPPTR(ss,ix);
7444 TOPPTR(nss,ix) = gv_dup(gv);
7446 case SAVEt_HV: /* hash reference */
7447 hv = (HV*)POPPTR(ss,ix);
7448 TOPPTR(nss,ix) = hv_dup_inc(hv);
7449 gv = (GV*)POPPTR(ss,ix);
7450 TOPPTR(nss,ix) = gv_dup(gv);
7452 case SAVEt_INT: /* int reference */
7453 ptr = POPPTR(ss,ix);
7454 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7455 intval = (int)POPINT(ss,ix);
7456 TOPINT(nss,ix) = intval;
7458 case SAVEt_LONG: /* long reference */
7459 ptr = POPPTR(ss,ix);
7460 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7461 longval = (long)POPLONG(ss,ix);
7462 TOPLONG(nss,ix) = longval;
7464 case SAVEt_I32: /* I32 reference */
7465 case SAVEt_I16: /* I16 reference */
7466 case SAVEt_I8: /* I8 reference */
7467 ptr = POPPTR(ss,ix);
7468 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7472 case SAVEt_IV: /* IV reference */
7473 ptr = POPPTR(ss,ix);
7474 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7478 case SAVEt_SPTR: /* SV* reference */
7479 ptr = POPPTR(ss,ix);
7480 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7481 sv = (SV*)POPPTR(ss,ix);
7482 TOPPTR(nss,ix) = sv_dup(sv);
7484 case SAVEt_VPTR: /* random* reference */
7485 ptr = POPPTR(ss,ix);
7486 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7487 ptr = POPPTR(ss,ix);
7488 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7490 case SAVEt_PPTR: /* char* reference */
7491 ptr = POPPTR(ss,ix);
7492 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7493 c = (char*)POPPTR(ss,ix);
7494 TOPPTR(nss,ix) = pv_dup(c);
7496 case SAVEt_HPTR: /* HV* reference */
7497 ptr = POPPTR(ss,ix);
7498 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7499 hv = (HV*)POPPTR(ss,ix);
7500 TOPPTR(nss,ix) = hv_dup(hv);
7502 case SAVEt_APTR: /* AV* reference */
7503 ptr = POPPTR(ss,ix);
7504 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
7505 av = (AV*)POPPTR(ss,ix);
7506 TOPPTR(nss,ix) = av_dup(av);
7509 gv = (GV*)POPPTR(ss,ix);
7510 TOPPTR(nss,ix) = gv_dup(gv);
7512 case SAVEt_GP: /* scalar reference */
7513 gp = (GP*)POPPTR(ss,ix);
7514 TOPPTR(nss,ix) = gp = gp_dup(gp);
7515 (void)GpREFCNT_inc(gp);
7516 gv = (GV*)POPPTR(ss,ix);
7517 TOPPTR(nss,ix) = gv_dup_inc(c);
7518 c = (char*)POPPTR(ss,ix);
7519 TOPPTR(nss,ix) = pv_dup(c);
7526 sv = (SV*)POPPTR(ss,ix);
7527 TOPPTR(nss,ix) = sv_dup_inc(sv);
7530 ptr = POPPTR(ss,ix);
7531 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
7532 /* these are assumed to be refcounted properly */
7533 switch (((OP*)ptr)->op_type) {
7540 TOPPTR(nss,ix) = ptr;
7545 TOPPTR(nss,ix) = Nullop;
7550 TOPPTR(nss,ix) = Nullop;
7553 c = (char*)POPPTR(ss,ix);
7554 TOPPTR(nss,ix) = pv_dup_inc(c);
7557 longval = POPLONG(ss,ix);
7558 TOPLONG(nss,ix) = longval;
7561 hv = (HV*)POPPTR(ss,ix);
7562 TOPPTR(nss,ix) = hv_dup_inc(hv);
7563 c = (char*)POPPTR(ss,ix);
7564 TOPPTR(nss,ix) = pv_dup_inc(c);
7568 case SAVEt_DESTRUCTOR:
7569 ptr = POPPTR(ss,ix);
7570 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7571 dptr = POPDPTR(ss,ix);
7572 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
7574 case SAVEt_DESTRUCTOR_X:
7575 ptr = POPPTR(ss,ix);
7576 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
7577 dxptr = POPDXPTR(ss,ix);
7578 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
7580 case SAVEt_REGCONTEXT:
7586 case SAVEt_STACK_POS: /* Position on Perl stack */
7590 case SAVEt_AELEM: /* array element */
7591 sv = (SV*)POPPTR(ss,ix);
7592 TOPPTR(nss,ix) = sv_dup_inc(sv);
7595 av = (AV*)POPPTR(ss,ix);
7596 TOPPTR(nss,ix) = av_dup_inc(av);
7598 case SAVEt_HELEM: /* hash element */
7599 sv = (SV*)POPPTR(ss,ix);
7600 TOPPTR(nss,ix) = sv_dup_inc(sv);
7601 sv = (SV*)POPPTR(ss,ix);
7602 TOPPTR(nss,ix) = sv_dup_inc(sv);
7603 hv = (HV*)POPPTR(ss,ix);
7604 TOPPTR(nss,ix) = hv_dup_inc(hv);
7607 ptr = POPPTR(ss,ix);
7608 TOPPTR(nss,ix) = ptr;
7615 av = (AV*)POPPTR(ss,ix);
7616 TOPPTR(nss,ix) = av_dup(av);
7619 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
7631 perl_clone(PerlInterpreter *proto_perl, UV flags)
7634 CPerlObj *pPerl = (CPerlObj*)proto_perl;
7637 #ifdef PERL_IMPLICIT_SYS
7638 return perl_clone_using(proto_perl, flags,
7640 proto_perl->IMemShared,
7641 proto_perl->IMemParse,
7651 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
7652 struct IPerlMem* ipM, struct IPerlMem* ipMS,
7653 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
7654 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
7655 struct IPerlDir* ipD, struct IPerlSock* ipS,
7656 struct IPerlProc* ipP)
7658 /* XXX many of the string copies here can be optimized if they're
7659 * constants; they need to be allocated as common memory and just
7660 * their pointers copied. */
7664 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
7666 PERL_SET_THX(pPerl);
7667 # else /* !PERL_OBJECT */
7668 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
7669 PERL_SET_THX(my_perl);
7672 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7677 # else /* !DEBUGGING */
7678 Zero(my_perl, 1, PerlInterpreter);
7679 # endif /* DEBUGGING */
7683 PL_MemShared = ipMS;
7691 # endif /* PERL_OBJECT */
7692 #else /* !PERL_IMPLICIT_SYS */
7694 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
7695 PERL_SET_THX(my_perl);
7698 memset(my_perl, 0xab, sizeof(PerlInterpreter));
7703 # else /* !DEBUGGING */
7704 Zero(my_perl, 1, PerlInterpreter);
7705 # endif /* DEBUGGING */
7706 #endif /* PERL_IMPLICIT_SYS */
7709 PL_xiv_arenaroot = NULL;
7711 PL_xnv_arenaroot = NULL;
7713 PL_xrv_arenaroot = NULL;
7715 PL_xpv_arenaroot = NULL;
7717 PL_xpviv_arenaroot = NULL;
7718 PL_xpviv_root = NULL;
7719 PL_xpvnv_arenaroot = NULL;
7720 PL_xpvnv_root = NULL;
7721 PL_xpvcv_arenaroot = NULL;
7722 PL_xpvcv_root = NULL;
7723 PL_xpvav_arenaroot = NULL;
7724 PL_xpvav_root = NULL;
7725 PL_xpvhv_arenaroot = NULL;
7726 PL_xpvhv_root = NULL;
7727 PL_xpvmg_arenaroot = NULL;
7728 PL_xpvmg_root = NULL;
7729 PL_xpvlv_arenaroot = NULL;
7730 PL_xpvlv_root = NULL;
7731 PL_xpvbm_arenaroot = NULL;
7732 PL_xpvbm_root = NULL;
7733 PL_he_arenaroot = NULL;
7735 PL_nice_chunk = NULL;
7736 PL_nice_chunk_size = 0;
7739 PL_sv_root = Nullsv;
7740 PL_sv_arenaroot = Nullsv;
7742 PL_debug = proto_perl->Idebug;
7744 /* create SV map for pointer relocation */
7745 PL_ptr_table = ptr_table_new();
7747 /* initialize these special pointers as early as possible */
7748 SvANY(&PL_sv_undef) = NULL;
7749 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
7750 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
7751 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
7754 SvUPGRADE(&PL_sv_no, SVt_PVNV);
7756 SvANY(&PL_sv_no) = new_XPVNV();
7758 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
7759 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7760 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
7761 SvCUR(&PL_sv_no) = 0;
7762 SvLEN(&PL_sv_no) = 1;
7763 SvNVX(&PL_sv_no) = 0;
7764 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
7767 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
7769 SvANY(&PL_sv_yes) = new_XPVNV();
7771 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
7772 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
7773 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
7774 SvCUR(&PL_sv_yes) = 1;
7775 SvLEN(&PL_sv_yes) = 2;
7776 SvNVX(&PL_sv_yes) = 1;
7777 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
7779 /* create shared string table */
7780 PL_strtab = newHV();
7781 HvSHAREKEYS_off(PL_strtab);
7782 hv_ksplit(PL_strtab, 512);
7783 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
7785 PL_compiling = proto_perl->Icompiling;
7786 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
7787 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
7788 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
7789 if (!specialWARN(PL_compiling.cop_warnings))
7790 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
7791 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
7793 /* pseudo environmental stuff */
7794 PL_origargc = proto_perl->Iorigargc;
7796 New(0, PL_origargv, i+1, char*);
7797 PL_origargv[i] = '\0';
7799 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
7801 PL_envgv = gv_dup(proto_perl->Ienvgv);
7802 PL_incgv = gv_dup(proto_perl->Iincgv);
7803 PL_hintgv = gv_dup(proto_perl->Ihintgv);
7804 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
7805 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
7806 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
7809 PL_minus_c = proto_perl->Iminus_c;
7810 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
7811 PL_localpatches = proto_perl->Ilocalpatches;
7812 PL_splitstr = proto_perl->Isplitstr;
7813 PL_preprocess = proto_perl->Ipreprocess;
7814 PL_minus_n = proto_perl->Iminus_n;
7815 PL_minus_p = proto_perl->Iminus_p;
7816 PL_minus_l = proto_perl->Iminus_l;
7817 PL_minus_a = proto_perl->Iminus_a;
7818 PL_minus_F = proto_perl->Iminus_F;
7819 PL_doswitches = proto_perl->Idoswitches;
7820 PL_dowarn = proto_perl->Idowarn;
7821 PL_doextract = proto_perl->Idoextract;
7822 PL_sawampersand = proto_perl->Isawampersand;
7823 PL_unsafe = proto_perl->Iunsafe;
7824 PL_inplace = SAVEPV(proto_perl->Iinplace);
7825 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
7826 PL_perldb = proto_perl->Iperldb;
7827 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
7829 /* magical thingies */
7830 /* XXX time(&PL_basetime) when asked for? */
7831 PL_basetime = proto_perl->Ibasetime;
7832 PL_formfeed = sv_dup(proto_perl->Iformfeed);
7834 PL_maxsysfd = proto_perl->Imaxsysfd;
7835 PL_multiline = proto_perl->Imultiline;
7836 PL_statusvalue = proto_perl->Istatusvalue;
7838 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
7841 /* shortcuts to various I/O objects */
7842 PL_stdingv = gv_dup(proto_perl->Istdingv);
7843 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
7844 PL_defgv = gv_dup(proto_perl->Idefgv);
7845 PL_argvgv = gv_dup(proto_perl->Iargvgv);
7846 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
7847 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
7849 /* shortcuts to regexp stuff */
7850 PL_replgv = gv_dup(proto_perl->Ireplgv);
7852 /* shortcuts to misc objects */
7853 PL_errgv = gv_dup(proto_perl->Ierrgv);
7855 /* shortcuts to debugging objects */
7856 PL_DBgv = gv_dup(proto_perl->IDBgv);
7857 PL_DBline = gv_dup(proto_perl->IDBline);
7858 PL_DBsub = gv_dup(proto_perl->IDBsub);
7859 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
7860 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
7861 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
7862 PL_lineary = av_dup(proto_perl->Ilineary);
7863 PL_dbargs = av_dup(proto_perl->Idbargs);
7866 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
7867 PL_curstash = hv_dup(proto_perl->Tcurstash);
7868 PL_debstash = hv_dup(proto_perl->Idebstash);
7869 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
7870 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
7872 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
7873 PL_endav = av_dup_inc(proto_perl->Iendav);
7874 PL_checkav = av_dup_inc(proto_perl->Icheckav);
7875 PL_initav = av_dup_inc(proto_perl->Iinitav);
7877 PL_sub_generation = proto_perl->Isub_generation;
7879 /* funky return mechanisms */
7880 PL_forkprocess = proto_perl->Iforkprocess;
7882 /* subprocess state */
7883 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
7885 /* internal state */
7886 PL_tainting = proto_perl->Itainting;
7887 PL_maxo = proto_perl->Imaxo;
7888 if (proto_perl->Iop_mask)
7889 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
7891 PL_op_mask = Nullch;
7893 /* current interpreter roots */
7894 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
7895 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
7896 PL_main_start = proto_perl->Imain_start;
7897 PL_eval_root = proto_perl->Ieval_root;
7898 PL_eval_start = proto_perl->Ieval_start;
7900 /* runtime control stuff */
7901 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
7902 PL_copline = proto_perl->Icopline;
7904 PL_filemode = proto_perl->Ifilemode;
7905 PL_lastfd = proto_perl->Ilastfd;
7906 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
7909 PL_gensym = proto_perl->Igensym;
7910 PL_preambled = proto_perl->Ipreambled;
7911 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
7912 PL_laststatval = proto_perl->Ilaststatval;
7913 PL_laststype = proto_perl->Ilaststype;
7914 PL_mess_sv = Nullsv;
7916 PL_orslen = proto_perl->Iorslen;
7917 PL_ors = SAVEPVN(proto_perl->Iors, PL_orslen);
7918 PL_ofmt = SAVEPV(proto_perl->Iofmt);
7920 /* interpreter atexit processing */
7921 PL_exitlistlen = proto_perl->Iexitlistlen;
7922 if (PL_exitlistlen) {
7923 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7924 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
7927 PL_exitlist = (PerlExitListEntry*)NULL;
7928 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
7930 PL_profiledata = NULL;
7931 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
7932 /* PL_rsfp_filters entries have fake IoDIRP() */
7933 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
7935 PL_compcv = cv_dup(proto_perl->Icompcv);
7936 PL_comppad = av_dup(proto_perl->Icomppad);
7937 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
7938 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
7939 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
7940 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
7941 proto_perl->Tcurpad);
7943 #ifdef HAVE_INTERP_INTERN
7944 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
7947 /* more statics moved here */
7948 PL_generation = proto_perl->Igeneration;
7949 PL_DBcv = cv_dup(proto_perl->IDBcv);
7951 PL_in_clean_objs = proto_perl->Iin_clean_objs;
7952 PL_in_clean_all = proto_perl->Iin_clean_all;
7954 PL_uid = proto_perl->Iuid;
7955 PL_euid = proto_perl->Ieuid;
7956 PL_gid = proto_perl->Igid;
7957 PL_egid = proto_perl->Iegid;
7958 PL_nomemok = proto_perl->Inomemok;
7959 PL_an = proto_perl->Ian;
7960 PL_cop_seqmax = proto_perl->Icop_seqmax;
7961 PL_op_seqmax = proto_perl->Iop_seqmax;
7962 PL_evalseq = proto_perl->Ievalseq;
7963 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
7964 PL_origalen = proto_perl->Iorigalen;
7965 PL_pidstatus = newHV(); /* XXX flag for cloning? */
7966 PL_osname = SAVEPV(proto_perl->Iosname);
7967 PL_sh_path = SAVEPV(proto_perl->Ish_path);
7968 PL_sighandlerp = proto_perl->Isighandlerp;
7971 PL_runops = proto_perl->Irunops;
7973 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
7976 PL_cshlen = proto_perl->Icshlen;
7977 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
7980 PL_lex_state = proto_perl->Ilex_state;
7981 PL_lex_defer = proto_perl->Ilex_defer;
7982 PL_lex_expect = proto_perl->Ilex_expect;
7983 PL_lex_formbrack = proto_perl->Ilex_formbrack;
7984 PL_lex_dojoin = proto_perl->Ilex_dojoin;
7985 PL_lex_starts = proto_perl->Ilex_starts;
7986 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
7987 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
7988 PL_lex_op = proto_perl->Ilex_op;
7989 PL_lex_inpat = proto_perl->Ilex_inpat;
7990 PL_lex_inwhat = proto_perl->Ilex_inwhat;
7991 PL_lex_brackets = proto_perl->Ilex_brackets;
7992 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
7993 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
7994 PL_lex_casemods = proto_perl->Ilex_casemods;
7995 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
7996 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
7998 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
7999 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8000 PL_nexttoke = proto_perl->Inexttoke;
8002 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8003 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8004 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8005 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8006 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8007 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8008 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8009 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8010 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8011 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8012 PL_pending_ident = proto_perl->Ipending_ident;
8013 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8015 PL_expect = proto_perl->Iexpect;
8017 PL_multi_start = proto_perl->Imulti_start;
8018 PL_multi_end = proto_perl->Imulti_end;
8019 PL_multi_open = proto_perl->Imulti_open;
8020 PL_multi_close = proto_perl->Imulti_close;
8022 PL_error_count = proto_perl->Ierror_count;
8023 PL_subline = proto_perl->Isubline;
8024 PL_subname = sv_dup_inc(proto_perl->Isubname);
8026 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8027 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8028 PL_padix = proto_perl->Ipadix;
8029 PL_padix_floor = proto_perl->Ipadix_floor;
8030 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8032 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8033 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8034 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8035 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8036 PL_last_lop_op = proto_perl->Ilast_lop_op;
8037 PL_in_my = proto_perl->Iin_my;
8038 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8040 PL_cryptseen = proto_perl->Icryptseen;
8043 PL_hints = proto_perl->Ihints;
8045 PL_amagic_generation = proto_perl->Iamagic_generation;
8047 #ifdef USE_LOCALE_COLLATE
8048 PL_collation_ix = proto_perl->Icollation_ix;
8049 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8050 PL_collation_standard = proto_perl->Icollation_standard;
8051 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8052 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8053 #endif /* USE_LOCALE_COLLATE */
8055 #ifdef USE_LOCALE_NUMERIC
8056 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8057 PL_numeric_standard = proto_perl->Inumeric_standard;
8058 PL_numeric_local = proto_perl->Inumeric_local;
8059 PL_numeric_radix = proto_perl->Inumeric_radix;
8060 #endif /* !USE_LOCALE_NUMERIC */
8062 /* utf8 character classes */
8063 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8064 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8065 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8066 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8067 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8068 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8069 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8070 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8071 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8072 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8073 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8074 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8075 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8076 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8077 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8078 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8079 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8082 PL_last_swash_hv = Nullhv; /* reinits on demand */
8083 PL_last_swash_klen = 0;
8084 PL_last_swash_key[0]= '\0';
8085 PL_last_swash_tmps = (U8*)NULL;
8086 PL_last_swash_slen = 0;
8088 /* perly.c globals */
8089 PL_yydebug = proto_perl->Iyydebug;
8090 PL_yynerrs = proto_perl->Iyynerrs;
8091 PL_yyerrflag = proto_perl->Iyyerrflag;
8092 PL_yychar = proto_perl->Iyychar;
8093 PL_yyval = proto_perl->Iyyval;
8094 PL_yylval = proto_perl->Iyylval;
8096 PL_glob_index = proto_perl->Iglob_index;
8097 PL_srand_called = proto_perl->Isrand_called;
8098 PL_uudmap['M'] = 0; /* reinits on demand */
8099 PL_bitcount = Nullch; /* reinits on demand */
8101 if (proto_perl->Ipsig_ptr) {
8102 int sig_num[] = { SIG_NUM };
8103 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8104 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8105 for (i = 1; PL_sig_name[i]; i++) {
8106 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8107 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8111 PL_psig_ptr = (SV**)NULL;
8112 PL_psig_name = (SV**)NULL;
8115 /* thrdvar.h stuff */
8118 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8119 PL_tmps_ix = proto_perl->Ttmps_ix;
8120 PL_tmps_max = proto_perl->Ttmps_max;
8121 PL_tmps_floor = proto_perl->Ttmps_floor;
8122 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8124 while (i <= PL_tmps_ix) {
8125 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8129 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8130 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8131 Newz(54, PL_markstack, i, I32);
8132 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8133 - proto_perl->Tmarkstack);
8134 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8135 - proto_perl->Tmarkstack);
8136 Copy(proto_perl->Tmarkstack, PL_markstack,
8137 PL_markstack_ptr - PL_markstack + 1, I32);
8139 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8140 * NOTE: unlike the others! */
8141 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8142 PL_scopestack_max = proto_perl->Tscopestack_max;
8143 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8144 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8146 /* next push_return() sets PL_retstack[PL_retstack_ix]
8147 * NOTE: unlike the others! */
8148 PL_retstack_ix = proto_perl->Tretstack_ix;
8149 PL_retstack_max = proto_perl->Tretstack_max;
8150 Newz(54, PL_retstack, PL_retstack_max, OP*);
8151 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8153 /* NOTE: si_dup() looks at PL_markstack */
8154 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8156 /* PL_curstack = PL_curstackinfo->si_stack; */
8157 PL_curstack = av_dup(proto_perl->Tcurstack);
8158 PL_mainstack = av_dup(proto_perl->Tmainstack);
8160 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8161 PL_stack_base = AvARRAY(PL_curstack);
8162 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8163 - proto_perl->Tstack_base);
8164 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8166 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8167 * NOTE: unlike the others! */
8168 PL_savestack_ix = proto_perl->Tsavestack_ix;
8169 PL_savestack_max = proto_perl->Tsavestack_max;
8170 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8171 PL_savestack = ss_dup(proto_perl);
8175 ENTER; /* perl_destruct() wants to LEAVE; */
8178 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8179 PL_top_env = &PL_start_env;
8181 PL_op = proto_perl->Top;
8184 PL_Xpv = (XPV*)NULL;
8185 PL_na = proto_perl->Tna;
8187 PL_statbuf = proto_perl->Tstatbuf;
8188 PL_statcache = proto_perl->Tstatcache;
8189 PL_statgv = gv_dup(proto_perl->Tstatgv);
8190 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8192 PL_timesbuf = proto_perl->Ttimesbuf;
8195 PL_tainted = proto_perl->Ttainted;
8196 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8197 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8198 PL_rs = sv_dup_inc(proto_perl->Trs);
8199 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8200 PL_ofslen = proto_perl->Tofslen;
8201 PL_ofs = SAVEPVN(proto_perl->Tofs, PL_ofslen);
8202 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8203 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8204 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8205 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8206 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8208 PL_restartop = proto_perl->Trestartop;
8209 PL_in_eval = proto_perl->Tin_eval;
8210 PL_delaymagic = proto_perl->Tdelaymagic;
8211 PL_dirty = proto_perl->Tdirty;
8212 PL_localizing = proto_perl->Tlocalizing;
8214 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8215 PL_protect = proto_perl->Tprotect;
8217 PL_errors = sv_dup_inc(proto_perl->Terrors);
8218 PL_av_fetch_sv = Nullsv;
8219 PL_hv_fetch_sv = Nullsv;
8220 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8221 PL_modcount = proto_perl->Tmodcount;
8222 PL_lastgotoprobe = Nullop;
8223 PL_dumpindent = proto_perl->Tdumpindent;
8225 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8226 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8227 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8228 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8229 PL_sortcxix = proto_perl->Tsortcxix;
8230 PL_efloatbuf = Nullch; /* reinits on demand */
8231 PL_efloatsize = 0; /* reinits on demand */
8235 PL_screamfirst = NULL;
8236 PL_screamnext = NULL;
8237 PL_maxscream = -1; /* reinits on demand */
8238 PL_lastscream = Nullsv;
8240 PL_watchaddr = NULL;
8241 PL_watchok = Nullch;
8243 PL_regdummy = proto_perl->Tregdummy;
8244 PL_regcomp_parse = Nullch;
8245 PL_regxend = Nullch;
8246 PL_regcode = (regnode*)NULL;
8249 PL_regprecomp = Nullch;
8254 PL_seen_zerolen = 0;
8256 PL_regcomp_rx = (regexp*)NULL;
8258 PL_colorset = 0; /* reinits PL_colors[] */
8259 /*PL_colors[6] = {0,0,0,0,0,0};*/
8260 PL_reg_whilem_seen = 0;
8261 PL_reginput = Nullch;
8264 PL_regstartp = (I32*)NULL;
8265 PL_regendp = (I32*)NULL;
8266 PL_reglastparen = (U32*)NULL;
8267 PL_regtill = Nullch;
8269 PL_reg_start_tmp = (char**)NULL;
8270 PL_reg_start_tmpl = 0;
8271 PL_regdata = (struct reg_data*)NULL;
8274 PL_reg_eval_set = 0;
8276 PL_regprogram = (regnode*)NULL;
8278 PL_regcc = (CURCUR*)NULL;
8279 PL_reg_call_cc = (struct re_cc_state*)NULL;
8280 PL_reg_re = (regexp*)NULL;
8281 PL_reg_ganch = Nullch;
8283 PL_reg_magic = (MAGIC*)NULL;
8285 PL_reg_oldcurpm = (PMOP*)NULL;
8286 PL_reg_curpm = (PMOP*)NULL;
8287 PL_reg_oldsaved = Nullch;
8288 PL_reg_oldsavedlen = 0;
8290 PL_reg_leftiter = 0;
8291 PL_reg_poscache = Nullch;
8292 PL_reg_poscache_size= 0;
8294 /* RE engine - function pointers */
8295 PL_regcompp = proto_perl->Tregcompp;
8296 PL_regexecp = proto_perl->Tregexecp;
8297 PL_regint_start = proto_perl->Tregint_start;
8298 PL_regint_string = proto_perl->Tregint_string;
8299 PL_regfree = proto_perl->Tregfree;
8301 PL_reginterp_cnt = 0;
8302 PL_reg_starttry = 0;
8305 return (PerlInterpreter*)pPerl;
8311 #else /* !USE_ITHREADS */
8317 #endif /* USE_ITHREADS */
8320 do_report_used(pTHXo_ SV *sv)
8322 if (SvTYPE(sv) != SVTYPEMASK) {
8323 PerlIO_printf(Perl_debug_log, "****\n");
8329 do_clean_objs(pTHXo_ SV *sv)
8333 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8334 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8335 if (SvWEAKREF(sv)) {
8346 /* XXX Might want to check arrays, etc. */
8349 #ifndef DISABLE_DESTRUCTOR_KLUDGE
8351 do_clean_named_objs(pTHXo_ SV *sv)
8353 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
8354 if ( SvOBJECT(GvSV(sv)) ||
8355 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
8356 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
8357 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
8358 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
8360 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
8368 do_clean_all(pTHXo_ SV *sv)
8370 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
8371 SvFLAGS(sv) |= SVf_BREAK;