3 * Copyright (c) 1991-2001, 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); \
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 (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
920 if (SvTYPE(sv) == mt)
926 switch (SvTYPE(sv)) {
947 else if (mt < SVt_PVIV)
964 pv = (char*)SvRV(sv);
984 else if (mt == SVt_NV)
995 del_XPVIV(SvANY(sv));
1005 del_XPVNV(SvANY(sv));
1013 magic = SvMAGIC(sv);
1014 stash = SvSTASH(sv);
1015 del_XPVMG(SvANY(sv));
1018 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1023 Perl_croak(aTHX_ "Can't upgrade to undef");
1025 SvANY(sv) = new_XIV();
1029 SvANY(sv) = new_XNV();
1033 SvANY(sv) = new_XRV();
1037 SvANY(sv) = new_XPV();
1043 SvANY(sv) = new_XPVIV();
1053 SvANY(sv) = new_XPVNV();
1061 SvANY(sv) = new_XPVMG();
1067 SvMAGIC(sv) = magic;
1068 SvSTASH(sv) = stash;
1071 SvANY(sv) = new_XPVLV();
1077 SvMAGIC(sv) = magic;
1078 SvSTASH(sv) = stash;
1085 SvANY(sv) = new_XPVAV();
1093 SvMAGIC(sv) = magic;
1094 SvSTASH(sv) = stash;
1100 SvANY(sv) = new_XPVHV();
1108 SvMAGIC(sv) = magic;
1109 SvSTASH(sv) = stash;
1116 SvANY(sv) = new_XPVCV();
1117 Zero(SvANY(sv), 1, XPVCV);
1123 SvMAGIC(sv) = magic;
1124 SvSTASH(sv) = stash;
1127 SvANY(sv) = new_XPVGV();
1133 SvMAGIC(sv) = magic;
1134 SvSTASH(sv) = stash;
1142 SvANY(sv) = new_XPVBM();
1148 SvMAGIC(sv) = magic;
1149 SvSTASH(sv) = stash;
1155 SvANY(sv) = new_XPVFM();
1156 Zero(SvANY(sv), 1, XPVFM);
1162 SvMAGIC(sv) = magic;
1163 SvSTASH(sv) = stash;
1166 SvANY(sv) = new_XPVIO();
1167 Zero(SvANY(sv), 1, XPVIO);
1173 SvMAGIC(sv) = magic;
1174 SvSTASH(sv) = stash;
1175 IoPAGE_LEN(sv) = 60;
1178 SvFLAGS(sv) &= ~SVTYPEMASK;
1184 Perl_sv_backoff(pTHX_ register SV *sv)
1188 char *s = SvPVX(sv);
1189 SvLEN(sv) += SvIVX(sv);
1190 SvPVX(sv) -= SvIVX(sv);
1192 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1194 SvFLAGS(sv) &= ~SVf_OOK;
1201 Expands the character buffer in the SV. This will use C<sv_unref> and will
1202 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1209 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1213 #ifdef HAS_64K_LIMIT
1214 if (newlen >= 0x10000) {
1215 PerlIO_printf(Perl_debug_log,
1216 "Allocation too large: %"UVxf"\n", (UV)newlen);
1219 #endif /* HAS_64K_LIMIT */
1222 if (SvTYPE(sv) < SVt_PV) {
1223 sv_upgrade(sv, SVt_PV);
1226 else if (SvOOK(sv)) { /* pv is offset? */
1229 if (newlen > SvLEN(sv))
1230 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1231 #ifdef HAS_64K_LIMIT
1232 if (newlen >= 0x10000)
1238 if (newlen > SvLEN(sv)) { /* need more room? */
1239 if (SvLEN(sv) && s) {
1240 #if defined(MYMALLOC) && !defined(LEAKTEST)
1241 STRLEN l = malloced_size((void*)SvPVX(sv));
1247 Renew(s,newlen,char);
1250 New(703,s,newlen,char);
1252 SvLEN_set(sv, newlen);
1258 =for apidoc sv_setiv
1260 Copies an integer into the given SV. Does not handle 'set' magic. See
1267 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1269 SV_CHECK_THINKFIRST(sv);
1270 switch (SvTYPE(sv)) {
1272 sv_upgrade(sv, SVt_IV);
1275 sv_upgrade(sv, SVt_PVNV);
1279 sv_upgrade(sv, SVt_PVIV);
1288 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1289 PL_op_desc[PL_op->op_type]);
1291 (void)SvIOK_only(sv); /* validate number */
1297 =for apidoc sv_setiv_mg
1299 Like C<sv_setiv>, but also handles 'set' magic.
1305 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1312 =for apidoc sv_setuv
1314 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1321 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1323 /* With these two if statements:
1324 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1327 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1329 If you wish to remove them, please benchmark to see what the effect is
1331 if (u <= (UV)IV_MAX) {
1332 sv_setiv(sv, (IV)u);
1341 =for apidoc sv_setuv_mg
1343 Like C<sv_setuv>, but also handles 'set' magic.
1349 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1351 /* With these two if statements:
1352 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1355 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1357 If you wish to remove them, please benchmark to see what the effect is
1359 if (u <= (UV)IV_MAX) {
1360 sv_setiv(sv, (IV)u);
1370 =for apidoc sv_setnv
1372 Copies a double into the given SV. Does not handle 'set' magic. See
1379 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1381 SV_CHECK_THINKFIRST(sv);
1382 switch (SvTYPE(sv)) {
1385 sv_upgrade(sv, SVt_NV);
1390 sv_upgrade(sv, SVt_PVNV);
1399 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1400 PL_op_name[PL_op->op_type]);
1403 (void)SvNOK_only(sv); /* validate number */
1408 =for apidoc sv_setnv_mg
1410 Like C<sv_setnv>, but also handles 'set' magic.
1416 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1423 S_not_a_number(pTHX_ SV *sv)
1428 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1429 /* each *s can expand to 4 chars + "...\0",
1430 i.e. need room for 8 chars */
1432 for (s = SvPVX(sv); *s && d < limit; s++) {
1434 if (ch & 128 && !isPRINT_LC(ch)) {
1443 else if (ch == '\r') {
1447 else if (ch == '\f') {
1451 else if (ch == '\\') {
1455 else if (isPRINT_LC(ch))
1470 Perl_warner(aTHX_ WARN_NUMERIC,
1471 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1472 PL_op_desc[PL_op->op_type]);
1474 Perl_warner(aTHX_ WARN_NUMERIC,
1475 "Argument \"%s\" isn't numeric", tmpbuf);
1478 /* the number can be converted to integer with atol() or atoll() although */
1479 #define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
1480 #define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
1481 #define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
1482 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1483 #define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
1484 #define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
1485 #define IS_NUMBER_NEG 0x40 /* seen a leading - */
1486 #define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
1488 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1489 until proven guilty, assume that things are not that bad... */
1491 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1492 an IV (an assumption perl has been based on to date) it becomes necessary
1493 to remove the assumption that the NV always carries enough precision to
1494 recreate the IV whenever needed, and that the NV is the canonical form.
1495 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1496 precision as an side effect of conversion (which would lead to insanity
1497 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1498 1) to distinguish between IV/UV/NV slots that have cached a valid
1499 conversion where precision was lost and IV/UV/NV slots that have a
1500 valid conversion which has lost no precision
1501 2) to ensure that if a numeric conversion to one form is request that
1502 would lose precision, the precise conversion (or differently
1503 imprecise conversion) is also performed and cached, to prevent
1504 requests for different numeric formats on the same SV causing
1505 lossy conversion chains. (lossless conversion chains are perfectly
1510 SvIOKp is true if the IV slot contains a valid value
1511 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1512 SvNOKp is true if the NV slot contains a valid value
1513 SvNOK is true only if the NV value is accurate
1516 while converting from PV to NV check to see if converting that NV to an
1517 IV(or UV) would lose accuracy over a direct conversion from PV to
1518 IV(or UV). If it would, cache both conversions, return NV, but mark
1519 SV as IOK NOKp (ie not NOK).
1521 while converting from PV to IV check to see if converting that IV to an
1522 NV would lose accuracy over a direct conversion from PV to NV. If it
1523 would, cache both conversions, flag similarly.
1525 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1526 correctly because if IV & NV were set NV *always* overruled.
1527 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1528 changes - now IV and NV together means that the two are interchangeable
1529 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1531 The benefit of this is operations such as pp_add know that if SvIOK is
1532 true for both left and right operands, then integer addition can be
1533 used instead of floating point. (for cases where the result won't
1534 overflow) Before, floating point was always used, which could lead to
1535 loss of precision compared with integer addition.
1537 * making IV and NV equal status should make maths accurate on 64 bit
1539 * may speed up maths somewhat if pp_add and friends start to use
1540 integers when possible instead of fp. (hopefully the overhead in
1541 looking for SvIOK and checking for overflow will not outweigh the
1542 fp to integer speedup)
1543 * will slow down integer operations (callers of SvIV) on "inaccurate"
1544 values, as the change from SvIOK to SvIOKp will cause a call into
1545 sv_2iv each time rather than a macro access direct to the IV slot
1546 * should speed up number->string conversion on integers as IV is
1547 favoured when IV and NV equally accurate
1549 ####################################################################
1550 You had better be using SvIOK_notUV if you want an IV for arithmetic
1551 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1552 SvUOK is true iff UV.
1553 ####################################################################
1555 Your mileage will vary depending your CPUs relative fp to integer
1559 #ifndef NV_PRESERVES_UV
1560 #define IS_NUMBER_UNDERFLOW_IV 1
1561 #define IS_NUMBER_UNDERFLOW_UV 2
1562 #define IS_NUMBER_IV_AND_UV 2
1563 #define IS_NUMBER_OVERFLOW_IV 4
1564 #define IS_NUMBER_OVERFLOW_UV 5
1565 /* Hopefully your optimiser will consider inlining these two functions. */
1567 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1568 NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
1569 UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
1570 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, (UV)numtype));
1571 if (nv_as_uv <= (UV)IV_MAX) {
1572 (void)SvIOKp_on(sv);
1573 (void)SvNOKp_on(sv);
1574 /* Within suitable range to fit in an IV, atol won't overflow */
1575 /* XXX quite sure? Is that your final answer? not really, I'm
1576 trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1577 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1578 if (numtype & IS_NUMBER_NOT_INT) {
1579 /* I believe that even if the original PV had decimals, they
1580 are lost beyond the limit of the FP precision.
1581 However, neither is canonical, so both only get p flags.
1583 /* Both already have p flags, so do nothing */
1584 } else if (SvIVX(sv) == I_V(nv)) {
1589 /* It had no "." so it must be integer. assert (get in here from
1590 sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1591 IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1592 conversion routines need audit. */
1594 return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1596 /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1597 (void)SvIOKp_on(sv);
1598 (void)SvNOKp_on(sv);
1601 int save_errno = errno;
1603 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1605 if (numtype & IS_NUMBER_NOT_INT) {
1606 /* UV and NV both imprecise. */
1608 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1617 return IS_NUMBER_OVERFLOW_IV;
1621 /* Must have just overflowed UV, but not enough that an NV could spot
1623 return IS_NUMBER_OVERFLOW_UV;
1626 /* We've just lost integer precision, nothing we could do. */
1627 SvUVX(sv) = nv_as_uv;
1628 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, (UV)numtype));
1629 /* UV and NV slots equally valid only if we have casting symmetry. */
1630 if (numtype & IS_NUMBER_NOT_INT) {
1632 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1633 /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1634 UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1635 get to this point if NVs don't preserve UVs) */
1640 /* As above, I believe UV at least as good as NV */
1643 #endif /* HAS_STRTOUL */
1644 return IS_NUMBER_OVERFLOW_IV;
1647 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1649 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1651 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1652 if (SvNVX(sv) < (NV)IV_MIN) {
1653 (void)SvIOKp_on(sv);
1656 return IS_NUMBER_UNDERFLOW_IV;
1658 if (SvNVX(sv) > (NV)UV_MAX) {
1659 (void)SvIOKp_on(sv);
1663 return IS_NUMBER_OVERFLOW_UV;
1665 if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1666 (void)SvIOKp_on(sv);
1668 /* Can't use strtol etc to convert this string */
1669 if (SvNVX(sv) <= (UV)IV_MAX) {
1670 SvIVX(sv) = I_V(SvNVX(sv));
1671 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1672 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1674 /* Integer is imprecise. NOK, IOKp */
1676 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1679 SvUVX(sv) = U_V(SvNVX(sv));
1680 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1681 if (SvUVX(sv) == UV_MAX) {
1682 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1683 possibly be preserved by NV. Hence, it must be overflow.
1685 return IS_NUMBER_OVERFLOW_UV;
1687 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1689 /* Integer is imprecise. NOK, IOKp */
1691 return IS_NUMBER_OVERFLOW_IV;
1693 return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
1695 #endif /* NV_PRESERVES_UV*/
1698 Perl_sv_2iv(pTHX_ register SV *sv)
1702 if (SvGMAGICAL(sv)) {
1707 return I_V(SvNVX(sv));
1709 if (SvPOKp(sv) && SvLEN(sv))
1712 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1713 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1719 if (SvTHINKFIRST(sv)) {
1722 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1723 (SvRV(tmpstr) != SvRV(sv)))
1724 return SvIV(tmpstr);
1725 return PTR2IV(SvRV(sv));
1727 if (SvREADONLY(sv) && SvFAKE(sv)) {
1728 sv_force_normal(sv);
1730 if (SvREADONLY(sv) && !SvOK(sv)) {
1731 if (ckWARN(WARN_UNINITIALIZED))
1738 return (IV)(SvUVX(sv));
1745 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1746 * without also getting a cached IV/UV from it at the same time
1747 * (ie PV->NV conversion should detect loss of accuracy and cache
1748 * IV or UV at same time to avoid this. NWC */
1750 if (SvTYPE(sv) == SVt_NV)
1751 sv_upgrade(sv, SVt_PVNV);
1753 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1754 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1755 certainly cast into the IV range at IV_MAX, whereas the correct
1756 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1758 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1759 SvIVX(sv) = I_V(SvNVX(sv));
1760 if (SvNVX(sv) == (NV) SvIVX(sv)
1761 #ifndef NV_PRESERVES_UV
1762 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1763 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1764 /* Don't flag it as "accurately an integer" if the number
1765 came from a (by definition imprecise) NV operation, and
1766 we're outside the range of NV integer precision */
1769 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1770 DEBUG_c(PerlIO_printf(Perl_debug_log,
1771 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1777 /* IV not precise. No need to convert from PV, as NV
1778 conversion would already have cached IV if it detected
1779 that PV->IV would be better than PV->NV->IV
1780 flags already correct - don't set public IOK. */
1781 DEBUG_c(PerlIO_printf(Perl_debug_log,
1782 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1787 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1788 but the cast (NV)IV_MIN rounds to a the value less (more
1789 negative) than IV_MIN which happens to be equal to SvNVX ??
1790 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1791 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1792 (NV)UVX == NVX are both true, but the values differ. :-(
1793 Hopefully for 2s complement IV_MIN is something like
1794 0x8000000000000000 which will be exact. NWC */
1797 SvUVX(sv) = U_V(SvNVX(sv));
1799 (SvNVX(sv) == (NV) SvUVX(sv))
1800 #ifndef NV_PRESERVES_UV
1801 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1802 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1803 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1804 /* Don't flag it as "accurately an integer" if the number
1805 came from a (by definition imprecise) NV operation, and
1806 we're outside the range of NV integer precision */
1812 DEBUG_c(PerlIO_printf(Perl_debug_log,
1813 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1817 return (IV)SvUVX(sv);
1820 else if (SvPOKp(sv) && SvLEN(sv)) {
1821 I32 numtype = looks_like_number(sv);
1823 /* We want to avoid a possible problem when we cache an IV which
1824 may be later translated to an NV, and the resulting NV is not
1825 the translation of the initial data.
1827 This means that if we cache such an IV, we need to cache the
1828 NV as well. Moreover, we trade speed for space, and do not
1829 cache the NV if we are sure it's not needed.
1832 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1833 /* The NV may be reconstructed from IV - safe to cache IV,
1834 which may be calculated by atol(). */
1835 if (SvTYPE(sv) < SVt_PVIV)
1836 sv_upgrade(sv, SVt_PVIV);
1838 SvIVX(sv) = Atol(SvPVX(sv));
1842 int save_errno = errno;
1843 /* Is it an integer that we could convert with strtol?
1844 So try it, and if it doesn't set errno then it's pukka.
1845 This should be faster than going atof and then thinking. */
1846 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1847 == IS_NUMBER_TO_INT_BY_STRTOL)
1848 /* && is a sequence point. Without it not sure if I'm trying
1849 to do too much between sequence points and hence going
1851 && ((errno = 0), 1) /* , 1 so always true */
1852 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1854 if (SvTYPE(sv) < SVt_PVIV)
1855 sv_upgrade(sv, SVt_PVIV);
1864 /* Hopefully trace flow will optimise this away where possible
1868 /* It wasn't an integer, or it overflowed, or we don't have
1869 strtol. Do things the slow way - check if it's a UV etc. */
1870 d = Atof(SvPVX(sv));
1872 if (SvTYPE(sv) < SVt_PVNV)
1873 sv_upgrade(sv, SVt_PVNV);
1876 if (! numtype && ckWARN(WARN_NUMERIC))
1879 #if defined(USE_LONG_DOUBLE)
1880 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1881 PTR2UV(sv), SvNVX(sv)));
1883 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1884 PTR2UV(sv), SvNVX(sv)));
1888 #ifdef NV_PRESERVES_UV
1889 (void)SvIOKp_on(sv);
1891 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1892 SvIVX(sv) = I_V(SvNVX(sv));
1893 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1896 /* Integer is imprecise. NOK, IOKp */
1898 /* UV will not work better than IV */
1900 if (SvNVX(sv) > (NV)UV_MAX) {
1902 /* Integer is inaccurate. NOK, IOKp, is UV */
1906 SvUVX(sv) = U_V(SvNVX(sv));
1907 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1908 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1912 /* Integer is imprecise. NOK, IOKp, is UV */
1918 #else /* NV_PRESERVES_UV */
1919 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1920 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1921 /* Small enough to preserve all bits. */
1922 (void)SvIOKp_on(sv);
1924 SvIVX(sv) = I_V(SvNVX(sv));
1925 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1927 /* Assumption: first non-preserved integer is < IV_MAX,
1928 this NV is in the preserved range, therefore: */
1929 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1931 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
1933 } else if (sv_2iuv_non_preserve (sv, numtype)
1934 >= IS_NUMBER_OVERFLOW_IV)
1936 #endif /* NV_PRESERVES_UV */
1940 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1942 if (SvTYPE(sv) < SVt_IV)
1943 /* Typically the caller expects that sv_any is not NULL now. */
1944 sv_upgrade(sv, SVt_IV);
1947 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1948 PTR2UV(sv),SvIVX(sv)));
1949 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1953 Perl_sv_2uv(pTHX_ register SV *sv)
1957 if (SvGMAGICAL(sv)) {
1962 return U_V(SvNVX(sv));
1963 if (SvPOKp(sv) && SvLEN(sv))
1966 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1967 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1973 if (SvTHINKFIRST(sv)) {
1976 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1977 (SvRV(tmpstr) != SvRV(sv)))
1978 return SvUV(tmpstr);
1979 return PTR2UV(SvRV(sv));
1981 if (SvREADONLY(sv) && SvFAKE(sv)) {
1982 sv_force_normal(sv);
1984 if (SvREADONLY(sv) && !SvOK(sv)) {
1985 if (ckWARN(WARN_UNINITIALIZED))
1995 return (UV)SvIVX(sv);
1999 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2000 * without also getting a cached IV/UV from it at the same time
2001 * (ie PV->NV conversion should detect loss of accuracy and cache
2002 * IV or UV at same time to avoid this. */
2003 /* IV-over-UV optimisation - choose to cache IV if possible */
2005 if (SvTYPE(sv) == SVt_NV)
2006 sv_upgrade(sv, SVt_PVNV);
2008 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2009 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2010 SvIVX(sv) = I_V(SvNVX(sv));
2011 if (SvNVX(sv) == (NV) SvIVX(sv)
2012 #ifndef NV_PRESERVES_UV
2013 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2014 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2015 /* Don't flag it as "accurately an integer" if the number
2016 came from a (by definition imprecise) NV operation, and
2017 we're outside the range of NV integer precision */
2020 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2021 DEBUG_c(PerlIO_printf(Perl_debug_log,
2022 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2028 /* IV not precise. No need to convert from PV, as NV
2029 conversion would already have cached IV if it detected
2030 that PV->IV would be better than PV->NV->IV
2031 flags already correct - don't set public IOK. */
2032 DEBUG_c(PerlIO_printf(Perl_debug_log,
2033 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2038 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2039 but the cast (NV)IV_MIN rounds to a the value less (more
2040 negative) than IV_MIN which happens to be equal to SvNVX ??
2041 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2042 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2043 (NV)UVX == NVX are both true, but the values differ. :-(
2044 Hopefully for 2s complement IV_MIN is something like
2045 0x8000000000000000 which will be exact. NWC */
2048 SvUVX(sv) = U_V(SvNVX(sv));
2050 (SvNVX(sv) == (NV) SvUVX(sv))
2051 #ifndef NV_PRESERVES_UV
2052 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2053 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2054 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2055 /* Don't flag it as "accurately an integer" if the number
2056 came from a (by definition imprecise) NV operation, and
2057 we're outside the range of NV integer precision */
2062 DEBUG_c(PerlIO_printf(Perl_debug_log,
2063 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2069 else if (SvPOKp(sv) && SvLEN(sv)) {
2070 I32 numtype = looks_like_number(sv);
2072 /* We want to avoid a possible problem when we cache a UV which
2073 may be later translated to an NV, and the resulting NV is not
2074 the translation of the initial data.
2076 This means that if we cache such a UV, we need to cache the
2077 NV as well. Moreover, we trade speed for space, and do not
2078 cache the NV if not needed.
2081 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2082 /* The NV may be reconstructed from IV - safe to cache IV,
2083 which may be calculated by atol(). */
2084 if (SvTYPE(sv) < SVt_PVIV)
2085 sv_upgrade(sv, SVt_PVIV);
2087 SvIVX(sv) = Atol(SvPVX(sv));
2091 char *num_begin = SvPVX(sv);
2092 int save_errno = errno;
2094 /* seems that strtoul taking numbers that start with - is
2095 implementation dependant, and can't be relied upon. */
2096 if (numtype & IS_NUMBER_NEG) {
2097 /* Not totally defensive. assumine that looks_like_num
2098 didn't lie about a - sign */
2099 while (isSPACE(*num_begin))
2101 if (*num_begin == '-')
2105 /* Is it an integer that we could convert with strtoul?
2106 So try it, and if it doesn't set errno then it's pukka.
2107 This should be faster than going atof and then thinking. */
2108 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2109 == IS_NUMBER_TO_INT_BY_STRTOL)
2110 && ((errno = 0), 1) /* always true */
2111 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2113 /* If known to be negative, check it didn't undeflow IV
2114 XXX possibly we should put more negative values as NVs
2115 direct rather than go via atof below */
2116 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2119 if (SvTYPE(sv) < SVt_PVIV)
2120 sv_upgrade(sv, SVt_PVIV);
2123 /* If it's negative must use IV.
2124 IV-over-UV optimisation */
2125 if (numtype & IS_NUMBER_NEG) {
2127 } else if (u <= (UV) IV_MAX) {
2130 /* it didn't overflow, and it was positive. */
2139 /* Hopefully trace flow will optimise this away where possible
2143 /* It wasn't an integer, or it overflowed, or we don't have
2144 strtol. Do things the slow way - check if it's a IV etc. */
2145 d = Atof(SvPVX(sv));
2147 if (SvTYPE(sv) < SVt_PVNV)
2148 sv_upgrade(sv, SVt_PVNV);
2151 if (! numtype && ckWARN(WARN_NUMERIC))
2154 #if defined(USE_LONG_DOUBLE)
2155 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2156 PTR2UV(sv), SvNVX(sv)));
2158 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2159 PTR2UV(sv), SvNVX(sv)));
2162 #ifdef NV_PRESERVES_UV
2163 (void)SvIOKp_on(sv);
2165 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2166 SvIVX(sv) = I_V(SvNVX(sv));
2167 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2170 /* Integer is imprecise. NOK, IOKp */
2172 /* UV will not work better than IV */
2174 if (SvNVX(sv) > (NV)UV_MAX) {
2176 /* Integer is inaccurate. NOK, IOKp, is UV */
2180 SvUVX(sv) = U_V(SvNVX(sv));
2181 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2182 NV preservse UV so can do correct comparison. */
2183 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2187 /* Integer is imprecise. NOK, IOKp, is UV */
2192 #else /* NV_PRESERVES_UV */
2193 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2194 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2195 /* Small enough to preserve all bits. */
2196 (void)SvIOKp_on(sv);
2198 SvIVX(sv) = I_V(SvNVX(sv));
2199 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2201 /* Assumption: first non-preserved integer is < IV_MAX,
2202 this NV is in the preserved range, therefore: */
2203 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2205 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2208 sv_2iuv_non_preserve (sv, numtype);
2209 #endif /* NV_PRESERVES_UV */
2214 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2215 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2218 if (SvTYPE(sv) < SVt_IV)
2219 /* Typically the caller expects that sv_any is not NULL now. */
2220 sv_upgrade(sv, SVt_IV);
2224 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2225 PTR2UV(sv),SvUVX(sv)));
2226 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2230 Perl_sv_2nv(pTHX_ register SV *sv)
2234 if (SvGMAGICAL(sv)) {
2238 if (SvPOKp(sv) && SvLEN(sv)) {
2239 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2241 return Atof(SvPVX(sv));
2245 return (NV)SvUVX(sv);
2247 return (NV)SvIVX(sv);
2250 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2251 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2257 if (SvTHINKFIRST(sv)) {
2260 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2261 (SvRV(tmpstr) != SvRV(sv)))
2262 return SvNV(tmpstr);
2263 return PTR2NV(SvRV(sv));
2265 if (SvREADONLY(sv) && SvFAKE(sv)) {
2266 sv_force_normal(sv);
2268 if (SvREADONLY(sv) && !SvOK(sv)) {
2269 if (ckWARN(WARN_UNINITIALIZED))
2274 if (SvTYPE(sv) < SVt_NV) {
2275 if (SvTYPE(sv) == SVt_IV)
2276 sv_upgrade(sv, SVt_PVNV);
2278 sv_upgrade(sv, SVt_NV);
2279 #if defined(USE_LONG_DOUBLE)
2281 STORE_NUMERIC_LOCAL_SET_STANDARD();
2282 PerlIO_printf(Perl_debug_log,
2283 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2284 PTR2UV(sv), SvNVX(sv));
2285 RESTORE_NUMERIC_LOCAL();
2289 STORE_NUMERIC_LOCAL_SET_STANDARD();
2290 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2291 PTR2UV(sv), SvNVX(sv));
2292 RESTORE_NUMERIC_LOCAL();
2296 else if (SvTYPE(sv) < SVt_PVNV)
2297 sv_upgrade(sv, SVt_PVNV);
2299 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2301 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2302 #ifdef NV_PRESERVES_UV
2305 /* Only set the public NV OK flag if this NV preserves the IV */
2306 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2307 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2308 : (SvIVX(sv) == I_V(SvNVX(sv))))
2314 else if (SvPOKp(sv) && SvLEN(sv)) {
2315 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2317 SvNVX(sv) = Atof(SvPVX(sv));
2318 #ifdef NV_PRESERVES_UV
2321 /* Only set the public NV OK flag if this NV preserves the value in
2322 the PV at least as well as an IV/UV would.
2323 Not sure how to do this 100% reliably. */
2324 /* if that shift count is out of range then Configure's test is
2325 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2327 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2328 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2329 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2330 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2331 /* Definitely too large/small to fit in an integer, so no loss
2332 of precision going to integer in the future via NV */
2335 /* Is it something we can run through strtol etc (ie no
2336 trailing exponent part)? */
2337 int numtype = looks_like_number(sv);
2338 /* XXX probably should cache this if called above */
2341 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2342 /* Can't use strtol etc to convert this string, so don't try */
2345 sv_2inuv_non_preserve (sv, numtype);
2347 #endif /* NV_PRESERVES_UV */
2350 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2352 if (SvTYPE(sv) < SVt_NV)
2353 /* Typically the caller expects that sv_any is not NULL now. */
2354 /* XXX Ilya implies that this is a bug in callers that assume this
2355 and ideally should be fixed. */
2356 sv_upgrade(sv, SVt_NV);
2359 #if defined(USE_LONG_DOUBLE)
2361 STORE_NUMERIC_LOCAL_SET_STANDARD();
2362 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2363 PTR2UV(sv), SvNVX(sv));
2364 RESTORE_NUMERIC_LOCAL();
2368 STORE_NUMERIC_LOCAL_SET_STANDARD();
2369 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2370 PTR2UV(sv), SvNVX(sv));
2371 RESTORE_NUMERIC_LOCAL();
2378 S_asIV(pTHX_ SV *sv)
2380 I32 numtype = looks_like_number(sv);
2383 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2384 return Atol(SvPVX(sv));
2386 if (ckWARN(WARN_NUMERIC))
2389 d = Atof(SvPVX(sv));
2394 S_asUV(pTHX_ SV *sv)
2396 I32 numtype = looks_like_number(sv);
2399 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2400 return Strtoul(SvPVX(sv), Null(char**), 10);
2403 if (ckWARN(WARN_NUMERIC))
2406 return U_V(Atof(SvPVX(sv)));
2410 * Returns a combination of (advisory only - can get false negatives)
2411 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2412 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2413 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2414 * 0 if does not look like number.
2416 * (atol and strtol stop when they hit a decimal point. strtol will return
2417 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2418 * do this, and vendors have had 11 years to get it right.
2419 * However, will try to make it still work with only atol
2421 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2422 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2423 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2424 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2425 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2426 * IS_NUMBER_NOT_INT saw "." or "e"
2428 * IS_NUMBER_INFINITY
2432 =for apidoc looks_like_number
2434 Test if an the content of an SV looks like a number (or is a
2435 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2436 issue a non-numeric warning), even if your atof() doesn't grok them.
2442 Perl_looks_like_number(pTHX_ SV *sv)
2445 register char *send;
2446 register char *sbegin;
2447 register char *nbegin;
2451 #ifdef USE_LOCALE_NUMERIC
2452 bool specialradix = FALSE;
2459 else if (SvPOKp(sv))
2460 sbegin = SvPV(sv, len);
2463 send = sbegin + len;
2470 numtype = IS_NUMBER_NEG;
2477 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2478 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2479 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2480 * will need (int)atof().
2483 /* next must be digit or the radix separator or beginning of infinity */
2487 } while (isDIGIT(*s));
2489 /* Aaargh. long long really is irritating.
2490 In the gospel according to ANSI 1989, it is an axiom that "long"
2491 is the longest integer type, and that if you don't know how long
2492 something is you can cast it to long, and nothing will be lost
2493 (except possibly speed of execution if long is slower than the
2495 Now, one can't be sure if the old rules apply, or long long
2496 (or some other newfangled thing) is actually longer than the
2497 (formerly) longest thing.
2499 /* This lot will work for 64 bit *as long as* either
2500 either long is 64 bit
2501 or we can find both strtol/strtoq and strtoul/strtouq
2502 If not, we really should refuse to let the user use 64 bit IVs
2503 By "64 bit" I really mean IVs that don't get preserved by NVs
2504 It also should work for 128 bit IVs. Can any lend me a machine to
2507 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2508 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2509 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2510 ? sizeof(long) : sizeof (IV))*8-1))
2511 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2513 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2514 digit less (IV_MAX= 9223372036854775807,
2515 UV_MAX= 18446744073709551615) so be cautious */
2516 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2519 #ifdef USE_LOCALE_NUMERIC
2520 || (specialradix = IS_NUMERIC_RADIX(s))
2523 #ifdef USE_LOCALE_NUMERIC
2525 s += SvCUR(PL_numeric_radix);
2529 numtype |= IS_NUMBER_NOT_INT;
2530 while (isDIGIT(*s)) /* optional digits after the radix */
2535 #ifdef USE_LOCALE_NUMERIC
2536 || (specialradix = IS_NUMERIC_RADIX(s))
2539 #ifdef USE_LOCALE_NUMERIC
2541 s += SvCUR(PL_numeric_radix);
2545 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2546 /* no digits before the radix means we need digits after it */
2550 } while (isDIGIT(*s));
2555 else if (*s == 'I' || *s == 'i') {
2556 s++; if (*s != 'N' && *s != 'n') return 0;
2557 s++; if (*s != 'F' && *s != 'f') return 0;
2558 s++; if (*s == 'I' || *s == 'i') {
2559 s++; if (*s != 'N' && *s != 'n') return 0;
2560 s++; if (*s != 'I' && *s != 'i') return 0;
2561 s++; if (*s != 'T' && *s != 't') return 0;
2562 s++; if (*s != 'Y' && *s != 'y') return 0;
2571 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2572 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2574 /* we can have an optional exponent part */
2575 if (*s == 'e' || *s == 'E') {
2576 numtype &= IS_NUMBER_NEG;
2577 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2579 if (*s == '+' || *s == '-')
2584 } while (isDIGIT(*s));
2594 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2595 return IS_NUMBER_TO_INT_BY_ATOL;
2600 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2603 return sv_2pv(sv, &n_a);
2606 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2608 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2610 char *ptr = buf + TYPE_CHARS(UV);
2624 *--ptr = '0' + (uv % 10);
2633 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2638 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2639 char *tmpbuf = tbuf;
2645 if (SvGMAGICAL(sv)) {
2653 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2655 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2660 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2665 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2666 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2673 if (SvTHINKFIRST(sv)) {
2676 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2677 (SvRV(tmpstr) != SvRV(sv)))
2678 return SvPV(tmpstr,*lp);
2685 switch (SvTYPE(sv)) {
2687 if ( ((SvFLAGS(sv) &
2688 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2689 == (SVs_OBJECT|SVs_RMG))
2690 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2691 && (mg = mg_find(sv, 'r'))) {
2692 regexp *re = (regexp *)mg->mg_obj;
2695 char *fptr = "msix";
2700 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2702 while((ch = *fptr++)) {
2704 reflags[left++] = ch;
2707 reflags[right--] = ch;
2712 reflags[left] = '-';
2716 mg->mg_len = re->prelen + 4 + left;
2717 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2718 Copy("(?", mg->mg_ptr, 2, char);
2719 Copy(reflags, mg->mg_ptr+2, left, char);
2720 Copy(":", mg->mg_ptr+left+2, 1, char);
2721 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2722 mg->mg_ptr[mg->mg_len - 1] = ')';
2723 mg->mg_ptr[mg->mg_len] = 0;
2725 PL_reginterp_cnt += re->program[0].next_off;
2737 case SVt_PVBM: if (SvROK(sv))
2740 s = "SCALAR"; break;
2741 case SVt_PVLV: s = "LVALUE"; break;
2742 case SVt_PVAV: s = "ARRAY"; break;
2743 case SVt_PVHV: s = "HASH"; break;
2744 case SVt_PVCV: s = "CODE"; break;
2745 case SVt_PVGV: s = "GLOB"; break;
2746 case SVt_PVFM: s = "FORMAT"; break;
2747 case SVt_PVIO: s = "IO"; break;
2748 default: s = "UNKNOWN"; break;
2752 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2755 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2761 if (SvREADONLY(sv) && !SvOK(sv)) {
2762 if (ckWARN(WARN_UNINITIALIZED))
2768 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2769 /* I'm assuming that if both IV and NV are equally valid then
2770 converting the IV is going to be more efficient */
2771 U32 isIOK = SvIOK(sv);
2772 U32 isUIOK = SvIsUV(sv);
2773 char buf[TYPE_CHARS(UV)];
2776 if (SvTYPE(sv) < SVt_PVIV)
2777 sv_upgrade(sv, SVt_PVIV);
2779 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2781 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2782 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2783 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2784 SvCUR_set(sv, ebuf - ptr);
2794 else if (SvNOKp(sv)) {
2795 if (SvTYPE(sv) < SVt_PVNV)
2796 sv_upgrade(sv, SVt_PVNV);
2797 /* The +20 is pure guesswork. Configure test needed. --jhi */
2798 SvGROW(sv, NV_DIG + 20);
2800 olderrno = errno; /* some Xenix systems wipe out errno here */
2802 if (SvNVX(sv) == 0.0)
2803 (void)strcpy(s,"0");
2807 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2810 #ifdef FIXNEGATIVEZERO
2811 if (*s == '-' && s[1] == '0' && !s[2])
2821 if (ckWARN(WARN_UNINITIALIZED)
2822 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2825 if (SvTYPE(sv) < SVt_PV)
2826 /* Typically the caller expects that sv_any is not NULL now. */
2827 sv_upgrade(sv, SVt_PV);
2830 *lp = s - SvPVX(sv);
2833 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2834 PTR2UV(sv),SvPVX(sv)));
2838 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2839 /* Sneaky stuff here */
2843 tsv = newSVpv(tmpbuf, 0);
2859 len = strlen(tmpbuf);
2861 #ifdef FIXNEGATIVEZERO
2862 if (len == 2 && t[0] == '-' && t[1] == '0') {
2867 (void)SvUPGRADE(sv, SVt_PV);
2869 s = SvGROW(sv, len + 1);
2878 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2881 return sv_2pvbyte(sv, &n_a);
2885 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2887 sv_utf8_downgrade(sv,0);
2888 return SvPV(sv,*lp);
2892 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2895 return sv_2pvutf8(sv, &n_a);
2899 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2901 sv_utf8_upgrade(sv);
2902 return SvPV(sv,*lp);
2905 /* This function is only called on magical items */
2907 Perl_sv_2bool(pTHX_ register SV *sv)
2916 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2917 (SvRV(tmpsv) != SvRV(sv)))
2918 return SvTRUE(tmpsv);
2919 return SvRV(sv) != 0;
2922 register XPV* Xpvtmp;
2923 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2924 (*Xpvtmp->xpv_pv > '0' ||
2925 Xpvtmp->xpv_cur > 1 ||
2926 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2933 return SvIVX(sv) != 0;
2936 return SvNVX(sv) != 0.0;
2944 =for apidoc sv_utf8_upgrade
2946 Convert the PV of an SV to its UTF8-encoded form.
2947 Forces the SV to string form it it is not already.
2948 Always sets the SvUTF8 flag to avoid future validity checks even
2949 if all the bytes have hibit clear.
2955 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2964 (void) SvPV_nolen(sv);
2969 if (SvREADONLY(sv) && SvFAKE(sv)) {
2970 sv_force_normal(sv);
2973 /* This function could be much more efficient if we had a FLAG in SVs
2974 * to signal if there are any hibit chars in the PV.
2975 * Given that there isn't make loop fast as possible
2977 s = (U8 *) SvPVX(sv);
2978 e = (U8 *) SvEND(sv);
2981 if ((hibit = !UTF8_IS_INVARIANT(*t++)))
2987 len = SvCUR(sv) + 1; /* Plus the \0 */
2988 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2989 SvCUR(sv) = len - 1;
2991 Safefree(s); /* No longer using what was there before. */
2992 SvLEN(sv) = len; /* No longer know the real size. */
2996 for (t = s; t < e; t++)
2997 *t = NATIVE_TO_ASCII(*t);
3000 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3006 =for apidoc sv_utf8_downgrade
3008 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3009 This may not be possible if the PV contains non-byte encoding characters;
3010 if this is the case, either returns false or, if C<fail_ok> is not
3017 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3019 if (SvPOK(sv) && SvUTF8(sv)) {
3024 if (SvREADONLY(sv) && SvFAKE(sv))
3025 sv_force_normal(sv);
3026 s = (U8 *) SvPV(sv, len);
3027 if (!utf8_to_bytes(s, &len)) {
3030 #ifdef USE_BYTES_DOWNGRADES
3033 U8 *e = (U8 *) SvEND(sv);
3036 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3037 if (first && ch > 255) {
3039 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3040 PL_op_desc[PL_op->op_type]);
3042 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3049 len = (d - (U8 *) SvPVX(sv));
3054 Perl_croak(aTHX_ "Wide character in %s",
3055 PL_op_desc[PL_op->op_type]);
3057 Perl_croak(aTHX_ "Wide character");
3068 =for apidoc sv_utf8_encode
3070 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3071 flag so that it looks like octets again. Used as a building block
3072 for encode_utf8 in Encode.xs
3078 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3080 (void) sv_utf8_upgrade(sv);
3085 =for apidoc sv_utf8_decode
3087 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3088 turn of SvUTF8 if needed so that we see characters. Used as a building block
3089 for decode_utf8 in Encode.xs
3097 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3103 /* The octets may have got themselves encoded - get them back as bytes */
3104 if (!sv_utf8_downgrade(sv, TRUE))
3107 /* it is actually just a matter of turning the utf8 flag on, but
3108 * we want to make sure everything inside is valid utf8 first.
3110 c = (U8 *) SvPVX(sv);
3111 if (!is_utf8_string(c, SvCUR(sv)+1))
3113 e = (U8 *) SvEND(sv);
3115 if (!UTF8_IS_INVARIANT(*c++)) {
3125 /* Note: sv_setsv() should not be called with a source string that needs
3126 * to be reused, since it may destroy the source string if it is marked
3131 =for apidoc sv_setsv
3133 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3134 The source SV may be destroyed if it is mortal. Does not handle 'set'
3135 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3142 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3144 register U32 sflags;
3150 SV_CHECK_THINKFIRST(dstr);
3152 sstr = &PL_sv_undef;
3153 stype = SvTYPE(sstr);
3154 dtype = SvTYPE(dstr);
3158 /* There's a lot of redundancy below but we're going for speed here */
3163 if (dtype != SVt_PVGV) {
3164 (void)SvOK_off(dstr);
3172 sv_upgrade(dstr, SVt_IV);
3175 sv_upgrade(dstr, SVt_PVNV);
3179 sv_upgrade(dstr, SVt_PVIV);
3182 (void)SvIOK_only(dstr);
3183 SvIVX(dstr) = SvIVX(sstr);
3186 if (SvTAINTED(sstr))
3197 sv_upgrade(dstr, SVt_NV);
3202 sv_upgrade(dstr, SVt_PVNV);
3205 SvNVX(dstr) = SvNVX(sstr);
3206 (void)SvNOK_only(dstr);
3207 if (SvTAINTED(sstr))
3215 sv_upgrade(dstr, SVt_RV);
3216 else if (dtype == SVt_PVGV &&
3217 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3220 if (GvIMPORTED(dstr) != GVf_IMPORTED
3221 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3223 GvIMPORTED_on(dstr);
3234 sv_upgrade(dstr, SVt_PV);
3237 if (dtype < SVt_PVIV)
3238 sv_upgrade(dstr, SVt_PVIV);
3241 if (dtype < SVt_PVNV)
3242 sv_upgrade(dstr, SVt_PVNV);
3249 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3250 PL_op_name[PL_op->op_type]);
3252 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3256 if (dtype <= SVt_PVGV) {
3258 if (dtype != SVt_PVGV) {
3259 char *name = GvNAME(sstr);
3260 STRLEN len = GvNAMELEN(sstr);
3261 sv_upgrade(dstr, SVt_PVGV);
3262 sv_magic(dstr, dstr, '*', Nullch, 0);
3263 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3264 GvNAME(dstr) = savepvn(name, len);
3265 GvNAMELEN(dstr) = len;
3266 SvFAKE_on(dstr); /* can coerce to non-glob */
3268 /* ahem, death to those who redefine active sort subs */
3269 else if (PL_curstackinfo->si_type == PERLSI_SORT
3270 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3271 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3274 #ifdef GV_SHARED_CHECK
3275 if (GvSHARED((GV*)dstr)) {
3276 Perl_croak(aTHX_ PL_no_modify);
3280 (void)SvOK_off(dstr);
3281 GvINTRO_off(dstr); /* one-shot flag */
3283 GvGP(dstr) = gp_ref(GvGP(sstr));
3284 if (SvTAINTED(sstr))
3286 if (GvIMPORTED(dstr) != GVf_IMPORTED
3287 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3289 GvIMPORTED_on(dstr);
3297 if (SvGMAGICAL(sstr)) {
3299 if (SvTYPE(sstr) != stype) {
3300 stype = SvTYPE(sstr);
3301 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3305 if (stype == SVt_PVLV)
3306 (void)SvUPGRADE(dstr, SVt_PVNV);
3308 (void)SvUPGRADE(dstr, stype);
3311 sflags = SvFLAGS(sstr);
3313 if (sflags & SVf_ROK) {
3314 if (dtype >= SVt_PV) {
3315 if (dtype == SVt_PVGV) {
3316 SV *sref = SvREFCNT_inc(SvRV(sstr));
3318 int intro = GvINTRO(dstr);
3320 #ifdef GV_SHARED_CHECK
3321 if (GvSHARED((GV*)dstr)) {
3322 Perl_croak(aTHX_ PL_no_modify);
3329 GvINTRO_off(dstr); /* one-shot flag */
3330 Newz(602,gp, 1, GP);
3331 GvGP(dstr) = gp_ref(gp);
3332 GvSV(dstr) = NEWSV(72,0);
3333 GvLINE(dstr) = CopLINE(PL_curcop);
3334 GvEGV(dstr) = (GV*)dstr;
3337 switch (SvTYPE(sref)) {
3340 SAVESPTR(GvAV(dstr));
3342 dref = (SV*)GvAV(dstr);
3343 GvAV(dstr) = (AV*)sref;
3344 if (!GvIMPORTED_AV(dstr)
3345 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3347 GvIMPORTED_AV_on(dstr);
3352 SAVESPTR(GvHV(dstr));
3354 dref = (SV*)GvHV(dstr);
3355 GvHV(dstr) = (HV*)sref;
3356 if (!GvIMPORTED_HV(dstr)
3357 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3359 GvIMPORTED_HV_on(dstr);
3364 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3365 SvREFCNT_dec(GvCV(dstr));
3366 GvCV(dstr) = Nullcv;
3367 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3368 PL_sub_generation++;
3370 SAVESPTR(GvCV(dstr));
3373 dref = (SV*)GvCV(dstr);
3374 if (GvCV(dstr) != (CV*)sref) {
3375 CV* cv = GvCV(dstr);
3377 if (!GvCVGEN((GV*)dstr) &&
3378 (CvROOT(cv) || CvXSUB(cv)))
3380 /* ahem, death to those who redefine
3381 * active sort subs */
3382 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3383 PL_sortcop == CvSTART(cv))
3385 "Can't redefine active sort subroutine %s",
3386 GvENAME((GV*)dstr));
3387 /* Redefining a sub - warning is mandatory if
3388 it was a const and its value changed. */
3389 if (ckWARN(WARN_REDEFINE)
3391 && (!CvCONST((CV*)sref)
3392 || sv_cmp(cv_const_sv(cv),
3393 cv_const_sv((CV*)sref)))))
3395 Perl_warner(aTHX_ WARN_REDEFINE,
3397 ? "Constant subroutine %s redefined"
3398 : "Subroutine %s redefined",
3399 GvENAME((GV*)dstr));
3402 cv_ckproto(cv, (GV*)dstr,
3403 SvPOK(sref) ? SvPVX(sref) : Nullch);
3405 GvCV(dstr) = (CV*)sref;
3406 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3407 GvASSUMECV_on(dstr);
3408 PL_sub_generation++;
3410 if (!GvIMPORTED_CV(dstr)
3411 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3413 GvIMPORTED_CV_on(dstr);
3418 SAVESPTR(GvIOp(dstr));
3420 dref = (SV*)GvIOp(dstr);
3421 GvIOp(dstr) = (IO*)sref;
3425 SAVESPTR(GvFORM(dstr));
3427 dref = (SV*)GvFORM(dstr);
3428 GvFORM(dstr) = (CV*)sref;
3432 SAVESPTR(GvSV(dstr));
3434 dref = (SV*)GvSV(dstr);
3436 if (!GvIMPORTED_SV(dstr)
3437 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3439 GvIMPORTED_SV_on(dstr);
3447 if (SvTAINTED(sstr))
3452 (void)SvOOK_off(dstr); /* backoff */
3454 Safefree(SvPVX(dstr));
3455 SvLEN(dstr)=SvCUR(dstr)=0;
3458 (void)SvOK_off(dstr);
3459 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3461 if (sflags & SVp_NOK) {
3463 /* Only set the public OK flag if the source has public OK. */
3464 if (sflags & SVf_NOK)
3465 SvFLAGS(dstr) |= SVf_NOK;
3466 SvNVX(dstr) = SvNVX(sstr);
3468 if (sflags & SVp_IOK) {
3469 (void)SvIOKp_on(dstr);
3470 if (sflags & SVf_IOK)
3471 SvFLAGS(dstr) |= SVf_IOK;
3472 if (sflags & SVf_IVisUV)
3474 SvIVX(dstr) = SvIVX(sstr);
3476 if (SvAMAGIC(sstr)) {
3480 else if (sflags & SVp_POK) {
3483 * Check to see if we can just swipe the string. If so, it's a
3484 * possible small lose on short strings, but a big win on long ones.
3485 * It might even be a win on short strings if SvPVX(dstr)
3486 * has to be allocated and SvPVX(sstr) has to be freed.
3489 if (SvTEMP(sstr) && /* slated for free anyway? */
3490 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3491 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3492 SvLEN(sstr) && /* and really is a string */
3493 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3495 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3497 SvFLAGS(dstr) &= ~SVf_OOK;
3498 Safefree(SvPVX(dstr) - SvIVX(dstr));
3500 else if (SvLEN(dstr))
3501 Safefree(SvPVX(dstr));
3503 (void)SvPOK_only(dstr);
3504 SvPV_set(dstr, SvPVX(sstr));
3505 SvLEN_set(dstr, SvLEN(sstr));
3506 SvCUR_set(dstr, SvCUR(sstr));
3509 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3510 SvPV_set(sstr, Nullch);
3515 else { /* have to copy actual string */
3516 STRLEN len = SvCUR(sstr);
3518 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3519 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3520 SvCUR_set(dstr, len);
3521 *SvEND(dstr) = '\0';
3522 (void)SvPOK_only(dstr);
3524 if (sflags & SVf_UTF8)
3527 if (sflags & SVp_NOK) {
3529 if (sflags & SVf_NOK)
3530 SvFLAGS(dstr) |= SVf_NOK;
3531 SvNVX(dstr) = SvNVX(sstr);
3533 if (sflags & SVp_IOK) {
3534 (void)SvIOKp_on(dstr);
3535 if (sflags & SVf_IOK)
3536 SvFLAGS(dstr) |= SVf_IOK;
3537 if (sflags & SVf_IVisUV)
3539 SvIVX(dstr) = SvIVX(sstr);
3542 else if (sflags & SVp_IOK) {
3543 if (sflags & SVf_IOK)
3544 (void)SvIOK_only(dstr);
3546 (void)SvOK_off(dstr);
3547 (void)SvIOKp_on(dstr);
3549 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3550 if (sflags & SVf_IVisUV)
3552 SvIVX(dstr) = SvIVX(sstr);
3553 if (sflags & SVp_NOK) {
3554 if (sflags & SVf_NOK)
3555 (void)SvNOK_on(dstr);
3557 (void)SvNOKp_on(dstr);
3558 SvNVX(dstr) = SvNVX(sstr);
3561 else if (sflags & SVp_NOK) {
3562 if (sflags & SVf_NOK)
3563 (void)SvNOK_only(dstr);
3565 (void)SvOK_off(dstr);
3568 SvNVX(dstr) = SvNVX(sstr);
3571 if (dtype == SVt_PVGV) {
3572 if (ckWARN(WARN_MISC))
3573 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3576 (void)SvOK_off(dstr);
3578 if (SvTAINTED(sstr))
3583 =for apidoc sv_setsv_mg
3585 Like C<sv_setsv>, but also handles 'set' magic.
3591 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3593 sv_setsv(dstr,sstr);
3598 =for apidoc sv_setpvn
3600 Copies a string into an SV. The C<len> parameter indicates the number of
3601 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3607 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3609 register char *dptr;
3611 SV_CHECK_THINKFIRST(sv);
3617 /* len is STRLEN which is unsigned, need to copy to signed */
3621 (void)SvUPGRADE(sv, SVt_PV);
3623 SvGROW(sv, len + 1);
3625 Move(ptr,dptr,len,char);
3628 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3633 =for apidoc sv_setpvn_mg
3635 Like C<sv_setpvn>, but also handles 'set' magic.
3641 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3643 sv_setpvn(sv,ptr,len);
3648 =for apidoc sv_setpv
3650 Copies a string into an SV. The string must be null-terminated. Does not
3651 handle 'set' magic. See C<sv_setpv_mg>.
3657 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3659 register STRLEN len;
3661 SV_CHECK_THINKFIRST(sv);
3667 (void)SvUPGRADE(sv, SVt_PV);
3669 SvGROW(sv, len + 1);
3670 Move(ptr,SvPVX(sv),len+1,char);
3672 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3677 =for apidoc sv_setpv_mg
3679 Like C<sv_setpv>, but also handles 'set' magic.
3685 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3692 =for apidoc sv_usepvn
3694 Tells an SV to use C<ptr> to find its string value. Normally the string is
3695 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3696 The C<ptr> should point to memory that was allocated by C<malloc>. The
3697 string length, C<len>, must be supplied. This function will realloc the
3698 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3699 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3700 See C<sv_usepvn_mg>.
3706 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3708 SV_CHECK_THINKFIRST(sv);
3709 (void)SvUPGRADE(sv, SVt_PV);
3714 (void)SvOOK_off(sv);
3715 if (SvPVX(sv) && SvLEN(sv))
3716 Safefree(SvPVX(sv));
3717 Renew(ptr, len+1, char);
3720 SvLEN_set(sv, len+1);
3722 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3727 =for apidoc sv_usepvn_mg
3729 Like C<sv_usepvn>, but also handles 'set' magic.
3735 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3737 sv_usepvn(sv,ptr,len);
3742 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3744 if (SvREADONLY(sv)) {
3746 char *pvx = SvPVX(sv);
3747 STRLEN len = SvCUR(sv);
3748 U32 hash = SvUVX(sv);
3749 SvGROW(sv, len + 1);
3750 Move(pvx,SvPVX(sv),len,char);
3754 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3756 else if (PL_curcop != &PL_compiling)
3757 Perl_croak(aTHX_ PL_no_modify);
3760 sv_unref_flags(sv, flags);
3761 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3766 Perl_sv_force_normal(pTHX_ register SV *sv)
3768 sv_force_normal_flags(sv, 0);
3774 Efficient removal of characters from the beginning of the string buffer.
3775 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3776 the string buffer. The C<ptr> becomes the first character of the adjusted
3783 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3787 register STRLEN delta;
3789 if (!ptr || !SvPOKp(sv))
3791 SV_CHECK_THINKFIRST(sv);
3792 if (SvTYPE(sv) < SVt_PVIV)
3793 sv_upgrade(sv,SVt_PVIV);
3796 if (!SvLEN(sv)) { /* make copy of shared string */
3797 char *pvx = SvPVX(sv);
3798 STRLEN len = SvCUR(sv);
3799 SvGROW(sv, len + 1);
3800 Move(pvx,SvPVX(sv),len,char);
3804 SvFLAGS(sv) |= SVf_OOK;
3806 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3807 delta = ptr - SvPVX(sv);
3815 =for apidoc sv_catpvn
3817 Concatenates the string onto the end of the string which is in the SV. The
3818 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3819 'set' magic. See C<sv_catpvn_mg>.
3825 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3830 junk = SvPV_force(sv, tlen);
3831 SvGROW(sv, tlen + len + 1);
3834 Move(ptr,SvPVX(sv)+tlen,len,char);
3837 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3842 =for apidoc sv_catpvn_mg
3844 Like C<sv_catpvn>, but also handles 'set' magic.
3850 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3852 sv_catpvn(sv,ptr,len);
3857 =for apidoc sv_catsv
3859 Concatenates the string from SV C<ssv> onto the end of the string in
3860 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3861 not 'set' magic. See C<sv_catsv_mg>.
3866 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3872 if ((spv = SvPV(ssv, slen))) {
3873 bool dutf8 = DO_UTF8(dsv);
3874 bool sutf8 = DO_UTF8(ssv);
3877 sv_catpvn(dsv,spv,slen);
3880 /* Not modifying source SV, so taking a temporary copy. */
3881 SV* csv = sv_2mortal(newSVsv(ssv));
3885 sv_utf8_upgrade(csv);
3886 cpv = SvPV(csv,clen);
3887 sv_catpvn(dsv,cpv,clen);
3890 sv_utf8_upgrade(dsv);
3891 sv_catpvn(dsv,spv,slen);
3892 SvUTF8_on(dsv); /* If dsv has no wide characters. */
3899 =for apidoc sv_catsv_mg
3901 Like C<sv_catsv>, but also handles 'set' magic.
3907 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3914 =for apidoc sv_catpv
3916 Concatenates the string onto the end of the string which is in the SV.
3917 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3923 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3925 register STRLEN len;
3931 junk = SvPV_force(sv, tlen);
3933 SvGROW(sv, tlen + len + 1);
3936 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3938 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3943 =for apidoc sv_catpv_mg
3945 Like C<sv_catpv>, but also handles 'set' magic.
3951 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3958 Perl_newSV(pTHX_ STRLEN len)
3964 sv_upgrade(sv, SVt_PV);
3965 SvGROW(sv, len + 1);
3970 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3973 =for apidoc sv_magic
3975 Adds magic to an SV.
3981 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3985 if (SvREADONLY(sv)) {
3986 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3987 Perl_croak(aTHX_ PL_no_modify);
3989 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3990 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3997 (void)SvUPGRADE(sv, SVt_PVMG);
3999 Newz(702,mg, 1, MAGIC);
4000 mg->mg_moremagic = SvMAGIC(sv);
4003 /* Some magic sontains a reference loop, where the sv and object refer to
4004 each other. To prevent a avoid a reference loop that would prevent such
4005 objects being freed, we look for such loops and if we find one we avoid
4006 incrementing the object refcount. */
4007 if (!obj || obj == sv || how == '#' || how == 'r' ||
4008 (SvTYPE(obj) == SVt_PVGV &&
4009 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4010 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4011 GvFORM(obj) == (CV*)sv)))
4016 mg->mg_obj = SvREFCNT_inc(obj);
4017 mg->mg_flags |= MGf_REFCOUNTED;
4020 mg->mg_len = namlen;
4023 mg->mg_ptr = savepvn(name, namlen);
4024 else if (namlen == HEf_SVKEY)
4025 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4030 mg->mg_virtual = &PL_vtbl_sv;
4033 mg->mg_virtual = &PL_vtbl_amagic;
4036 mg->mg_virtual = &PL_vtbl_amagicelem;
4039 mg->mg_virtual = &PL_vtbl_ovrld;
4042 mg->mg_virtual = &PL_vtbl_bm;
4045 mg->mg_virtual = &PL_vtbl_regdata;
4048 mg->mg_virtual = &PL_vtbl_regdatum;
4051 mg->mg_virtual = &PL_vtbl_env;
4054 mg->mg_virtual = &PL_vtbl_fm;
4057 mg->mg_virtual = &PL_vtbl_envelem;
4060 mg->mg_virtual = &PL_vtbl_mglob;
4063 mg->mg_virtual = &PL_vtbl_isa;
4066 mg->mg_virtual = &PL_vtbl_isaelem;
4069 mg->mg_virtual = &PL_vtbl_nkeys;
4076 mg->mg_virtual = &PL_vtbl_dbline;
4080 mg->mg_virtual = &PL_vtbl_mutex;
4082 #endif /* USE_THREADS */
4083 #ifdef USE_LOCALE_COLLATE
4085 mg->mg_virtual = &PL_vtbl_collxfrm;
4087 #endif /* USE_LOCALE_COLLATE */
4089 mg->mg_virtual = &PL_vtbl_pack;
4093 mg->mg_virtual = &PL_vtbl_packelem;
4096 mg->mg_virtual = &PL_vtbl_regexp;
4099 mg->mg_virtual = &PL_vtbl_sig;
4102 mg->mg_virtual = &PL_vtbl_sigelem;
4105 mg->mg_virtual = &PL_vtbl_taint;
4109 mg->mg_virtual = &PL_vtbl_uvar;
4112 mg->mg_virtual = &PL_vtbl_vec;
4115 mg->mg_virtual = &PL_vtbl_substr;
4118 mg->mg_virtual = &PL_vtbl_defelem;
4121 mg->mg_virtual = &PL_vtbl_glob;
4124 mg->mg_virtual = &PL_vtbl_arylen;
4127 mg->mg_virtual = &PL_vtbl_pos;
4130 mg->mg_virtual = &PL_vtbl_backref;
4132 case '~': /* Reserved for use by extensions not perl internals. */
4133 /* Useful for attaching extension internal data to perl vars. */
4134 /* Note that multiple extensions may clash if magical scalars */
4135 /* etc holding private data from one are passed to another. */
4139 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4143 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4147 =for apidoc sv_unmagic
4149 Removes magic from an SV.
4155 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4159 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4162 for (mg = *mgp; mg; mg = *mgp) {
4163 if (mg->mg_type == type) {
4164 MGVTBL* vtbl = mg->mg_virtual;
4165 *mgp = mg->mg_moremagic;
4166 if (vtbl && vtbl->svt_free)
4167 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4168 if (mg->mg_ptr && mg->mg_type != 'g') {
4169 if (mg->mg_len >= 0)
4170 Safefree(mg->mg_ptr);
4171 else if (mg->mg_len == HEf_SVKEY)
4172 SvREFCNT_dec((SV*)mg->mg_ptr);
4174 if (mg->mg_flags & MGf_REFCOUNTED)
4175 SvREFCNT_dec(mg->mg_obj);
4179 mgp = &mg->mg_moremagic;
4183 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4190 =for apidoc sv_rvweaken
4198 Perl_sv_rvweaken(pTHX_ SV *sv)
4201 if (!SvOK(sv)) /* let undefs pass */
4204 Perl_croak(aTHX_ "Can't weaken a nonreference");
4205 else if (SvWEAKREF(sv)) {
4206 if (ckWARN(WARN_MISC))
4207 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4211 sv_add_backref(tsv, sv);
4218 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4222 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4223 av = (AV*)mg->mg_obj;
4226 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4227 SvREFCNT_dec(av); /* for sv_magic */
4233 S_sv_del_backref(pTHX_ SV *sv)
4240 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4241 Perl_croak(aTHX_ "panic: del_backref");
4242 av = (AV *)mg->mg_obj;
4247 svp[i] = &PL_sv_undef; /* XXX */
4254 =for apidoc sv_insert
4256 Inserts a string at the specified offset/length within the SV. Similar to
4257 the Perl substr() function.
4263 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4267 register char *midend;
4268 register char *bigend;
4274 Perl_croak(aTHX_ "Can't modify non-existent substring");
4275 SvPV_force(bigstr, curlen);
4276 (void)SvPOK_only_UTF8(bigstr);
4277 if (offset + len > curlen) {
4278 SvGROW(bigstr, offset+len+1);
4279 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4280 SvCUR_set(bigstr, offset+len);
4284 i = littlelen - len;
4285 if (i > 0) { /* string might grow */
4286 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4287 mid = big + offset + len;
4288 midend = bigend = big + SvCUR(bigstr);
4291 while (midend > mid) /* shove everything down */
4292 *--bigend = *--midend;
4293 Move(little,big+offset,littlelen,char);
4299 Move(little,SvPVX(bigstr)+offset,len,char);
4304 big = SvPVX(bigstr);
4307 bigend = big + SvCUR(bigstr);
4309 if (midend > bigend)
4310 Perl_croak(aTHX_ "panic: sv_insert");
4312 if (mid - big > bigend - midend) { /* faster to shorten from end */
4314 Move(little, mid, littlelen,char);
4317 i = bigend - midend;
4319 Move(midend, mid, i,char);
4323 SvCUR_set(bigstr, mid - big);
4326 else if ((i = mid - big)) { /* faster from front */
4327 midend -= littlelen;
4329 sv_chop(bigstr,midend-i);
4334 Move(little, mid, littlelen,char);
4336 else if (littlelen) {
4337 midend -= littlelen;
4338 sv_chop(bigstr,midend);
4339 Move(little,midend,littlelen,char);
4342 sv_chop(bigstr,midend);
4348 =for apidoc sv_replace
4350 Make the first argument a copy of the second, then delete the original.
4356 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4358 U32 refcnt = SvREFCNT(sv);
4359 SV_CHECK_THINKFIRST(sv);
4360 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4361 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4362 if (SvMAGICAL(sv)) {
4366 sv_upgrade(nsv, SVt_PVMG);
4367 SvMAGIC(nsv) = SvMAGIC(sv);
4368 SvFLAGS(nsv) |= SvMAGICAL(sv);
4374 assert(!SvREFCNT(sv));
4375 StructCopy(nsv,sv,SV);
4376 SvREFCNT(sv) = refcnt;
4377 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4382 =for apidoc sv_clear
4384 Clear an SV, making it empty. Does not free the memory used by the SV
4391 Perl_sv_clear(pTHX_ register SV *sv)
4395 assert(SvREFCNT(sv) == 0);
4398 if (PL_defstash) { /* Still have a symbol table? */
4403 Zero(&tmpref, 1, SV);
4404 sv_upgrade(&tmpref, SVt_RV);
4406 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4407 SvREFCNT(&tmpref) = 1;
4410 stash = SvSTASH(sv);
4411 destructor = StashHANDLER(stash,DESTROY);
4414 PUSHSTACKi(PERLSI_DESTROY);
4415 SvRV(&tmpref) = SvREFCNT_inc(sv);
4420 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4426 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4428 del_XRV(SvANY(&tmpref));
4431 if (PL_in_clean_objs)
4432 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4434 /* DESTROY gave object new lease on life */
4440 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4441 SvOBJECT_off(sv); /* Curse the object. */
4442 if (SvTYPE(sv) != SVt_PVIO)
4443 --PL_sv_objcount; /* XXX Might want something more general */
4446 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4449 switch (SvTYPE(sv)) {
4452 IoIFP(sv) != PerlIO_stdin() &&
4453 IoIFP(sv) != PerlIO_stdout() &&
4454 IoIFP(sv) != PerlIO_stderr())
4456 io_close((IO*)sv, FALSE);
4458 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4459 PerlDir_close(IoDIRP(sv));
4460 IoDIRP(sv) = (DIR*)NULL;
4461 Safefree(IoTOP_NAME(sv));
4462 Safefree(IoFMT_NAME(sv));
4463 Safefree(IoBOTTOM_NAME(sv));
4478 SvREFCNT_dec(LvTARG(sv));
4482 Safefree(GvNAME(sv));
4483 /* cannot decrease stash refcount yet, as we might recursively delete
4484 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4485 of stash until current sv is completely gone.
4486 -- JohnPC, 27 Mar 1998 */
4487 stash = GvSTASH(sv);
4493 (void)SvOOK_off(sv);
4501 SvREFCNT_dec(SvRV(sv));
4503 else if (SvPVX(sv) && SvLEN(sv))
4504 Safefree(SvPVX(sv));
4505 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4506 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4518 switch (SvTYPE(sv)) {
4534 del_XPVIV(SvANY(sv));
4537 del_XPVNV(SvANY(sv));
4540 del_XPVMG(SvANY(sv));
4543 del_XPVLV(SvANY(sv));
4546 del_XPVAV(SvANY(sv));
4549 del_XPVHV(SvANY(sv));
4552 del_XPVCV(SvANY(sv));
4555 del_XPVGV(SvANY(sv));
4556 /* code duplication for increased performance. */
4557 SvFLAGS(sv) &= SVf_BREAK;
4558 SvFLAGS(sv) |= SVTYPEMASK;
4559 /* decrease refcount of the stash that owns this GV, if any */
4561 SvREFCNT_dec(stash);
4562 return; /* not break, SvFLAGS reset already happened */
4564 del_XPVBM(SvANY(sv));
4567 del_XPVFM(SvANY(sv));
4570 del_XPVIO(SvANY(sv));
4573 SvFLAGS(sv) &= SVf_BREAK;
4574 SvFLAGS(sv) |= SVTYPEMASK;
4578 Perl_sv_newref(pTHX_ SV *sv)
4581 ATOMIC_INC(SvREFCNT(sv));
4588 Free the memory used by an SV.
4594 Perl_sv_free(pTHX_ SV *sv)
4596 int refcount_is_zero;
4600 if (SvREFCNT(sv) == 0) {
4601 if (SvFLAGS(sv) & SVf_BREAK)
4603 if (PL_in_clean_all) /* All is fair */
4605 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4606 /* make sure SvREFCNT(sv)==0 happens very seldom */
4607 SvREFCNT(sv) = (~(U32)0)/2;
4610 if (ckWARN_d(WARN_INTERNAL))
4611 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4614 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4615 if (!refcount_is_zero)
4619 if (ckWARN_d(WARN_DEBUGGING))
4620 Perl_warner(aTHX_ WARN_DEBUGGING,
4621 "Attempt to free temp prematurely: SV 0x%"UVxf,
4626 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4627 /* make sure SvREFCNT(sv)==0 happens very seldom */
4628 SvREFCNT(sv) = (~(U32)0)/2;
4639 Returns the length of the string in the SV. See also C<SvCUR>.
4645 Perl_sv_len(pTHX_ register SV *sv)
4654 len = mg_length(sv);
4656 junk = SvPV(sv, len);
4661 =for apidoc sv_len_utf8
4663 Returns the number of characters in the string in an SV, counting wide
4664 UTF8 bytes as a single character.
4670 Perl_sv_len_utf8(pTHX_ register SV *sv)
4676 return mg_length(sv);
4680 U8 *s = (U8*)SvPV(sv, len);
4682 return Perl_utf8_length(aTHX_ s, s + len);
4687 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4692 I32 uoffset = *offsetp;
4698 start = s = (U8*)SvPV(sv, len);
4700 while (s < send && uoffset--)
4704 *offsetp = s - start;
4708 while (s < send && ulen--)
4718 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4727 s = (U8*)SvPV(sv, len);
4729 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4730 send = s + *offsetp;
4734 /* We can use low level directly here as we are not looking at the values */
4735 if (utf8n_to_uvuni(s, UTF8SKIP(s), &n, 0)) {
4749 Returns a boolean indicating whether the strings in the two SVs are
4756 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4770 pv1 = SvPV(sv1, cur1);
4777 pv2 = SvPV(sv2, cur2);
4779 /* do not utf8ize the comparands as a side-effect */
4780 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4781 bool is_utf8 = TRUE;
4782 /* UTF-8ness differs */
4783 if (PL_hints & HINT_UTF8_DISTINCT)
4787 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4788 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4793 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4794 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4799 /* Downgrade not possible - cannot be eq */
4805 eq = memEQ(pv1, pv2, cur1);
4816 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4817 string in C<sv1> is less than, equal to, or greater than the string in
4824 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4829 bool pv1tmp = FALSE;
4830 bool pv2tmp = FALSE;
4837 pv1 = SvPV(sv1, cur1);
4844 pv2 = SvPV(sv2, cur2);
4846 /* do not utf8ize the comparands as a side-effect */
4847 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4848 if (PL_hints & HINT_UTF8_DISTINCT)
4849 return SvUTF8(sv1) ? 1 : -1;
4852 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4856 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4862 cmp = cur2 ? -1 : 0;
4866 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4869 cmp = retval < 0 ? -1 : 1;
4870 } else if (cur1 == cur2) {
4873 cmp = cur1 < cur2 ? -1 : 1;
4886 =for apidoc sv_cmp_locale
4888 Compares the strings in two SVs in a locale-aware manner. See
4895 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4897 #ifdef USE_LOCALE_COLLATE
4903 if (PL_collation_standard)
4907 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4909 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4911 if (!pv1 || !len1) {
4922 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4925 return retval < 0 ? -1 : 1;
4928 * When the result of collation is equality, that doesn't mean
4929 * that there are no differences -- some locales exclude some
4930 * characters from consideration. So to avoid false equalities,
4931 * we use the raw string as a tiebreaker.
4937 #endif /* USE_LOCALE_COLLATE */
4939 return sv_cmp(sv1, sv2);
4942 #ifdef USE_LOCALE_COLLATE
4944 * Any scalar variable may carry an 'o' magic that contains the
4945 * scalar data of the variable transformed to such a format that
4946 * a normal memory comparison can be used to compare the data
4947 * according to the locale settings.
4950 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4954 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4955 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4960 Safefree(mg->mg_ptr);
4962 if ((xf = mem_collxfrm(s, len, &xlen))) {
4963 if (SvREADONLY(sv)) {
4966 return xf + sizeof(PL_collation_ix);
4969 sv_magic(sv, 0, 'o', 0, 0);
4970 mg = mg_find(sv, 'o');
4983 if (mg && mg->mg_ptr) {
4985 return mg->mg_ptr + sizeof(PL_collation_ix);
4993 #endif /* USE_LOCALE_COLLATE */
4998 Get a line from the filehandle and store it into the SV, optionally
4999 appending to the currently-stored string.
5005 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5009 register STDCHAR rslast;
5010 register STDCHAR *bp;
5014 SV_CHECK_THINKFIRST(sv);
5015 (void)SvUPGRADE(sv, SVt_PV);
5019 if (RsSNARF(PL_rs)) {
5023 else if (RsRECORD(PL_rs)) {
5024 I32 recsize, bytesread;
5027 /* Grab the size of the record we're getting */
5028 recsize = SvIV(SvRV(PL_rs));
5029 (void)SvPOK_only(sv); /* Validate pointer */
5030 buffer = SvGROW(sv, recsize + 1);
5033 /* VMS wants read instead of fread, because fread doesn't respect */
5034 /* RMS record boundaries. This is not necessarily a good thing to be */
5035 /* doing, but we've got no other real choice */
5036 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5038 bytesread = PerlIO_read(fp, buffer, recsize);
5040 SvCUR_set(sv, bytesread);
5041 buffer[bytesread] = '\0';
5042 if (PerlIO_isutf8(fp))
5046 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5048 else if (RsPARA(PL_rs)) {
5053 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5054 if (PerlIO_isutf8(fp)) {
5055 rsptr = SvPVutf8(PL_rs, rslen);
5058 if (SvUTF8(PL_rs)) {
5059 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5060 Perl_croak(aTHX_ "Wide character in $/");
5063 rsptr = SvPV(PL_rs, rslen);
5067 rslast = rslen ? rsptr[rslen - 1] : '\0';
5069 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5070 do { /* to make sure file boundaries work right */
5073 i = PerlIO_getc(fp);
5077 PerlIO_ungetc(fp,i);
5083 /* See if we know enough about I/O mechanism to cheat it ! */
5085 /* This used to be #ifdef test - it is made run-time test for ease
5086 of abstracting out stdio interface. One call should be cheap
5087 enough here - and may even be a macro allowing compile
5091 if (PerlIO_fast_gets(fp)) {
5094 * We're going to steal some values from the stdio struct
5095 * and put EVERYTHING in the innermost loop into registers.
5097 register STDCHAR *ptr;
5101 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5102 /* An ungetc()d char is handled separately from the regular
5103 * buffer, so we getc() it back out and stuff it in the buffer.
5105 i = PerlIO_getc(fp);
5106 if (i == EOF) return 0;
5107 *(--((*fp)->_ptr)) = (unsigned char) i;
5111 /* Here is some breathtakingly efficient cheating */
5113 cnt = PerlIO_get_cnt(fp); /* get count into register */
5114 (void)SvPOK_only(sv); /* validate pointer */
5115 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5116 if (cnt > 80 && SvLEN(sv) > append) {
5117 shortbuffered = cnt - SvLEN(sv) + append + 1;
5118 cnt -= shortbuffered;
5122 /* remember that cnt can be negative */
5123 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5128 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5129 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5130 DEBUG_P(PerlIO_printf(Perl_debug_log,
5131 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5132 DEBUG_P(PerlIO_printf(Perl_debug_log,
5133 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5134 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5135 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5140 while (cnt > 0) { /* this | eat */
5142 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5143 goto thats_all_folks; /* screams | sed :-) */
5147 Copy(ptr, bp, cnt, char); /* this | eat */
5148 bp += cnt; /* screams | dust */
5149 ptr += cnt; /* louder | sed :-) */
5154 if (shortbuffered) { /* oh well, must extend */
5155 cnt = shortbuffered;
5157 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5159 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5160 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5164 DEBUG_P(PerlIO_printf(Perl_debug_log,
5165 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5166 PTR2UV(ptr),(long)cnt));
5167 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5168 DEBUG_P(PerlIO_printf(Perl_debug_log,
5169 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5170 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5171 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5172 /* This used to call 'filbuf' in stdio form, but as that behaves like
5173 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5174 another abstraction. */
5175 i = PerlIO_getc(fp); /* get more characters */
5176 DEBUG_P(PerlIO_printf(Perl_debug_log,
5177 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5178 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5179 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5180 cnt = PerlIO_get_cnt(fp);
5181 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5182 DEBUG_P(PerlIO_printf(Perl_debug_log,
5183 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5185 if (i == EOF) /* all done for ever? */
5186 goto thats_really_all_folks;
5188 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5190 SvGROW(sv, bpx + cnt + 2);
5191 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5193 *bp++ = i; /* store character from PerlIO_getc */
5195 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5196 goto thats_all_folks;
5200 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5201 memNE((char*)bp - rslen, rsptr, rslen))
5202 goto screamer; /* go back to the fray */
5203 thats_really_all_folks:
5205 cnt += shortbuffered;
5206 DEBUG_P(PerlIO_printf(Perl_debug_log,
5207 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5208 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5209 DEBUG_P(PerlIO_printf(Perl_debug_log,
5210 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5211 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5212 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5214 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5215 DEBUG_P(PerlIO_printf(Perl_debug_log,
5216 "Screamer: done, len=%ld, string=|%.*s|\n",
5217 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5222 /*The big, slow, and stupid way */
5225 /* Need to work around EPOC SDK features */
5226 /* On WINS: MS VC5 generates calls to _chkstk, */
5227 /* if a `large' stack frame is allocated */
5228 /* gcc on MARM does not generate calls like these */
5234 register STDCHAR *bpe = buf + sizeof(buf);
5236 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5237 ; /* keep reading */
5241 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5242 /* Accomodate broken VAXC compiler, which applies U8 cast to
5243 * both args of ?: operator, causing EOF to change into 255
5245 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5249 sv_catpvn(sv, (char *) buf, cnt);
5251 sv_setpvn(sv, (char *) buf, cnt);
5253 if (i != EOF && /* joy */
5255 SvCUR(sv) < rslen ||
5256 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5260 * If we're reading from a TTY and we get a short read,
5261 * indicating that the user hit his EOF character, we need
5262 * to notice it now, because if we try to read from the TTY
5263 * again, the EOF condition will disappear.
5265 * The comparison of cnt to sizeof(buf) is an optimization
5266 * that prevents unnecessary calls to feof().
5270 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5275 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5276 while (i != EOF) { /* to make sure file boundaries work right */
5277 i = PerlIO_getc(fp);
5279 PerlIO_ungetc(fp,i);
5285 if (PerlIO_isutf8(fp))
5290 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5297 Auto-increment of the value in the SV.
5303 Perl_sv_inc(pTHX_ register SV *sv)
5312 if (SvTHINKFIRST(sv)) {
5313 if (SvREADONLY(sv)) {
5314 if (PL_curcop != &PL_compiling)
5315 Perl_croak(aTHX_ PL_no_modify);
5319 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5321 i = PTR2IV(SvRV(sv));
5326 flags = SvFLAGS(sv);
5327 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5328 /* It's (privately or publicly) a float, but not tested as an
5329 integer, so test it to see. */
5331 flags = SvFLAGS(sv);
5333 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5334 /* It's publicly an integer, or privately an integer-not-float */
5337 if (SvUVX(sv) == UV_MAX)
5338 sv_setnv(sv, (NV)UV_MAX + 1.0);
5340 (void)SvIOK_only_UV(sv);
5343 if (SvIVX(sv) == IV_MAX)
5344 sv_setuv(sv, (UV)IV_MAX + 1);
5346 (void)SvIOK_only(sv);
5352 if (flags & SVp_NOK) {
5353 (void)SvNOK_only(sv);
5358 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5359 if ((flags & SVTYPEMASK) < SVt_PVIV)
5360 sv_upgrade(sv, SVt_IV);
5361 (void)SvIOK_only(sv);
5366 while (isALPHA(*d)) d++;
5367 while (isDIGIT(*d)) d++;
5369 #ifdef PERL_PRESERVE_IVUV
5370 /* Got to punt this an an integer if needs be, but we don't issue
5371 warnings. Probably ought to make the sv_iv_please() that does
5372 the conversion if possible, and silently. */
5373 I32 numtype = looks_like_number(sv);
5374 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5375 /* Need to try really hard to see if it's an integer.
5376 9.22337203685478e+18 is an integer.
5377 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5378 so $a="9.22337203685478e+18"; $a+0; $a++
5379 needs to be the same as $a="9.22337203685478e+18"; $a++
5386 /* sv_2iv *should* have made this an NV */
5387 if (flags & SVp_NOK) {
5388 (void)SvNOK_only(sv);
5392 /* I don't think we can get here. Maybe I should assert this
5393 And if we do get here I suspect that sv_setnv will croak. NWC
5395 #if defined(USE_LONG_DOUBLE)
5396 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
5397 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5399 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5400 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5403 #endif /* PERL_PRESERVE_IVUV */
5404 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5408 while (d >= SvPVX(sv)) {
5416 /* MKS: The original code here died if letters weren't consecutive.
5417 * at least it didn't have to worry about non-C locales. The
5418 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5419 * arranged in order (although not consecutively) and that only
5420 * [A-Za-z] are accepted by isALPHA in the C locale.
5422 if (*d != 'z' && *d != 'Z') {
5423 do { ++*d; } while (!isALPHA(*d));
5426 *(d--) -= 'z' - 'a';
5431 *(d--) -= 'z' - 'a' + 1;
5435 /* oh,oh, the number grew */
5436 SvGROW(sv, SvCUR(sv) + 2);
5438 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5449 Auto-decrement of the value in the SV.
5455 Perl_sv_dec(pTHX_ register SV *sv)
5463 if (SvTHINKFIRST(sv)) {
5464 if (SvREADONLY(sv)) {
5465 if (PL_curcop != &PL_compiling)
5466 Perl_croak(aTHX_ PL_no_modify);
5470 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5472 i = PTR2IV(SvRV(sv));
5477 /* Unlike sv_inc we don't have to worry about string-never-numbers
5478 and keeping them magic. But we mustn't warn on punting */
5479 flags = SvFLAGS(sv);
5480 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5481 /* It's publicly an integer, or privately an integer-not-float */
5484 if (SvUVX(sv) == 0) {
5485 (void)SvIOK_only(sv);
5489 (void)SvIOK_only_UV(sv);
5493 if (SvIVX(sv) == IV_MIN)
5494 sv_setnv(sv, (NV)IV_MIN - 1.0);
5496 (void)SvIOK_only(sv);
5502 if (flags & SVp_NOK) {
5504 (void)SvNOK_only(sv);
5507 if (!(flags & SVp_POK)) {
5508 if ((flags & SVTYPEMASK) < SVt_PVNV)
5509 sv_upgrade(sv, SVt_NV);
5511 (void)SvNOK_only(sv);
5514 #ifdef PERL_PRESERVE_IVUV
5516 I32 numtype = looks_like_number(sv);
5517 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5518 /* Need to try really hard to see if it's an integer.
5519 9.22337203685478e+18 is an integer.
5520 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5521 so $a="9.22337203685478e+18"; $a+0; $a--
5522 needs to be the same as $a="9.22337203685478e+18"; $a--
5529 /* sv_2iv *should* have made this an NV */
5530 if (flags & SVp_NOK) {
5531 (void)SvNOK_only(sv);
5535 /* I don't think we can get here. Maybe I should assert this
5536 And if we do get here I suspect that sv_setnv will croak. NWC
5538 #if defined(USE_LONG_DOUBLE)
5539 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%"PERL_PRIgldbl"\n",
5540 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5542 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5543 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5547 #endif /* PERL_PRESERVE_IVUV */
5548 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5552 =for apidoc sv_mortalcopy
5554 Creates a new SV which is a copy of the original SV. The new SV is marked
5560 /* Make a string that will exist for the duration of the expression
5561 * evaluation. Actually, it may have to last longer than that, but
5562 * hopefully we won't free it until it has been assigned to a
5563 * permanent location. */
5566 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5571 sv_setsv(sv,oldstr);
5573 PL_tmps_stack[++PL_tmps_ix] = sv;
5579 =for apidoc sv_newmortal
5581 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5587 Perl_sv_newmortal(pTHX)
5592 SvFLAGS(sv) = SVs_TEMP;
5594 PL_tmps_stack[++PL_tmps_ix] = sv;
5599 =for apidoc sv_2mortal
5601 Marks an SV as mortal. The SV will be destroyed when the current context
5607 /* same thing without the copying */
5610 Perl_sv_2mortal(pTHX_ register SV *sv)
5614 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5617 PL_tmps_stack[++PL_tmps_ix] = sv;
5625 Creates a new SV and copies a string into it. The reference count for the
5626 SV is set to 1. If C<len> is zero, Perl will compute the length using
5627 strlen(). For efficiency, consider using C<newSVpvn> instead.
5633 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5640 sv_setpvn(sv,s,len);
5645 =for apidoc newSVpvn
5647 Creates a new SV and copies a string into it. The reference count for the
5648 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5649 string. You are responsible for ensuring that the source string is at least
5656 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5661 sv_setpvn(sv,s,len);
5666 =for apidoc newSVpvn_share
5668 Creates a new SV and populates it with a string from
5669 the string table. Turns on READONLY and FAKE.
5670 The idea here is that as string table is used for shared hash
5671 keys these strings will have SvPVX == HeKEY and hash lookup
5672 will avoid string compare.
5678 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5681 bool is_utf8 = FALSE;
5686 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5687 STRLEN tmplen = len;
5688 /* See the note in hv.c:hv_fetch() --jhi */
5689 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5693 PERL_HASH(hash, src, len);
5695 sv_upgrade(sv, SVt_PVIV);
5696 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5708 #if defined(PERL_IMPLICIT_CONTEXT)
5710 Perl_newSVpvf_nocontext(const char* pat, ...)
5715 va_start(args, pat);
5716 sv = vnewSVpvf(pat, &args);
5723 =for apidoc newSVpvf
5725 Creates a new SV an initialize it with the string formatted like
5732 Perl_newSVpvf(pTHX_ const char* pat, ...)
5736 va_start(args, pat);
5737 sv = vnewSVpvf(pat, &args);
5743 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5747 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5754 Creates a new SV and copies a floating point value into it.
5755 The reference count for the SV is set to 1.
5761 Perl_newSVnv(pTHX_ NV n)
5773 Creates a new SV and copies an integer into it. The reference count for the
5780 Perl_newSViv(pTHX_ IV i)
5792 Creates a new SV and copies an unsigned integer into it.
5793 The reference count for the SV is set to 1.
5799 Perl_newSVuv(pTHX_ UV u)
5809 =for apidoc newRV_noinc
5811 Creates an RV wrapper for an SV. The reference count for the original
5812 SV is B<not> incremented.
5818 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5823 sv_upgrade(sv, SVt_RV);
5830 /* newRV_inc is #defined to newRV in sv.h */
5832 Perl_newRV(pTHX_ SV *tmpRef)
5834 return newRV_noinc(SvREFCNT_inc(tmpRef));
5840 Creates a new SV which is an exact duplicate of the original SV.
5845 /* make an exact duplicate of old */
5848 Perl_newSVsv(pTHX_ register SV *old)
5854 if (SvTYPE(old) == SVTYPEMASK) {
5855 if (ckWARN_d(WARN_INTERNAL))
5856 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5871 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5879 char todo[PERL_UCHAR_MAX+1];
5884 if (!*s) { /* reset ?? searches */
5885 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5886 pm->op_pmdynflags &= ~PMdf_USED;
5891 /* reset variables */
5893 if (!HvARRAY(stash))
5896 Zero(todo, 256, char);
5898 i = (unsigned char)*s;
5902 max = (unsigned char)*s++;
5903 for ( ; i <= max; i++) {
5906 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5907 for (entry = HvARRAY(stash)[i];
5909 entry = HeNEXT(entry))
5911 if (!todo[(U8)*HeKEY(entry)])
5913 gv = (GV*)HeVAL(entry);
5915 if (SvTHINKFIRST(sv)) {
5916 if (!SvREADONLY(sv) && SvROK(sv))
5921 if (SvTYPE(sv) >= SVt_PV) {
5923 if (SvPVX(sv) != Nullch)
5930 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5932 #ifdef USE_ENVIRON_ARRAY
5934 environ[0] = Nullch;
5943 Perl_sv_2io(pTHX_ SV *sv)
5949 switch (SvTYPE(sv)) {
5957 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5961 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5963 return sv_2io(SvRV(sv));
5964 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5970 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5977 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5984 return *gvp = Nullgv, Nullcv;
5985 switch (SvTYPE(sv)) {
6004 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6005 tryAMAGICunDEREF(to_cv);
6008 if (SvTYPE(sv) == SVt_PVCV) {
6017 Perl_croak(aTHX_ "Not a subroutine reference");
6022 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6028 if (lref && !GvCVu(gv)) {
6031 tmpsv = NEWSV(704,0);
6032 gv_efullname3(tmpsv, gv, Nullch);
6033 /* XXX this is probably not what they think they're getting.
6034 * It has the same effect as "sub name;", i.e. just a forward
6036 newSUB(start_subparse(FALSE, 0),
6037 newSVOP(OP_CONST, 0, tmpsv),
6042 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6051 Returns true if the SV has a true value by Perl's rules.
6057 Perl_sv_true(pTHX_ register SV *sv)
6063 if ((tXpv = (XPV*)SvANY(sv)) &&
6064 (tXpv->xpv_cur > 1 ||
6065 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6072 return SvIVX(sv) != 0;
6075 return SvNVX(sv) != 0.0;
6077 return sv_2bool(sv);
6083 Perl_sv_iv(pTHX_ register SV *sv)
6087 return (IV)SvUVX(sv);
6094 Perl_sv_uv(pTHX_ register SV *sv)
6099 return (UV)SvIVX(sv);
6105 Perl_sv_nv(pTHX_ register SV *sv)
6113 Perl_sv_pv(pTHX_ SV *sv)
6120 return sv_2pv(sv, &n_a);
6124 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6130 return sv_2pv(sv, lp);
6134 =for apidoc sv_pvn_force
6136 Get a sensible string out of the SV somehow.
6142 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6146 if (SvTHINKFIRST(sv) && !SvROK(sv))
6147 sv_force_normal(sv);
6153 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6154 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6155 PL_op_name[PL_op->op_type]);
6159 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6164 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6165 SvGROW(sv, len + 1);
6166 Move(s,SvPVX(sv),len,char);
6171 SvPOK_on(sv); /* validate pointer */
6173 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6174 PTR2UV(sv),SvPVX(sv)));
6181 Perl_sv_pvbyte(pTHX_ SV *sv)
6183 sv_utf8_downgrade(sv,0);
6188 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6190 sv_utf8_downgrade(sv,0);
6191 return sv_pvn(sv,lp);
6195 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6197 sv_utf8_downgrade(sv,0);
6198 return sv_pvn_force(sv,lp);
6202 Perl_sv_pvutf8(pTHX_ SV *sv)
6204 sv_utf8_upgrade(sv);
6209 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6211 sv_utf8_upgrade(sv);
6212 return sv_pvn(sv,lp);
6216 =for apidoc sv_pvutf8n_force
6218 Get a sensible UTF8-encoded string out of the SV somehow. See
6225 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6227 sv_utf8_upgrade(sv);
6228 return sv_pvn_force(sv,lp);
6232 =for apidoc sv_reftype
6234 Returns a string describing what the SV is a reference to.
6240 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6242 if (ob && SvOBJECT(sv))
6243 return HvNAME(SvSTASH(sv));
6245 switch (SvTYPE(sv)) {
6259 case SVt_PVLV: return "LVALUE";
6260 case SVt_PVAV: return "ARRAY";
6261 case SVt_PVHV: return "HASH";
6262 case SVt_PVCV: return "CODE";
6263 case SVt_PVGV: return "GLOB";
6264 case SVt_PVFM: return "FORMAT";
6265 case SVt_PVIO: return "IO";
6266 default: return "UNKNOWN";
6272 =for apidoc sv_isobject
6274 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6275 object. If the SV is not an RV, or if the object is not blessed, then this
6282 Perl_sv_isobject(pTHX_ SV *sv)
6299 Returns a boolean indicating whether the SV is blessed into the specified
6300 class. This does not check for subtypes; use C<sv_derived_from> to verify
6301 an inheritance relationship.
6307 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6319 return strEQ(HvNAME(SvSTASH(sv)), name);
6325 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6326 it will be upgraded to one. If C<classname> is non-null then the new SV will
6327 be blessed in the specified package. The new SV is returned and its
6328 reference count is 1.
6334 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6340 SV_CHECK_THINKFIRST(rv);
6343 if (SvTYPE(rv) >= SVt_PVMG) {
6344 U32 refcnt = SvREFCNT(rv);
6348 SvREFCNT(rv) = refcnt;
6351 if (SvTYPE(rv) < SVt_RV)
6352 sv_upgrade(rv, SVt_RV);
6353 else if (SvTYPE(rv) > SVt_RV) {
6354 (void)SvOOK_off(rv);
6355 if (SvPVX(rv) && SvLEN(rv))
6356 Safefree(SvPVX(rv));
6366 HV* stash = gv_stashpv(classname, TRUE);
6367 (void)sv_bless(rv, stash);
6373 =for apidoc sv_setref_pv
6375 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6376 argument will be upgraded to an RV. That RV will be modified to point to
6377 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6378 into the SV. The C<classname> argument indicates the package for the
6379 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6380 will be returned and will have a reference count of 1.
6382 Do not use with other Perl types such as HV, AV, SV, CV, because those
6383 objects will become corrupted by the pointer copy process.
6385 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6391 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6394 sv_setsv(rv, &PL_sv_undef);
6398 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6403 =for apidoc sv_setref_iv
6405 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6406 argument will be upgraded to an RV. That RV will be modified to point to
6407 the new SV. The C<classname> argument indicates the package for the
6408 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6409 will be returned and will have a reference count of 1.
6415 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6417 sv_setiv(newSVrv(rv,classname), iv);
6422 =for apidoc sv_setref_uv
6424 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6425 argument will be upgraded to an RV. That RV will be modified to point to
6426 the new SV. The C<classname> argument indicates the package for the
6427 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6428 will be returned and will have a reference count of 1.
6434 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6436 sv_setuv(newSVrv(rv,classname), uv);
6441 =for apidoc sv_setref_nv
6443 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6444 argument will be upgraded to an RV. That RV will be modified to point to
6445 the new SV. The C<classname> argument indicates the package for the
6446 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6447 will be returned and will have a reference count of 1.
6453 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6455 sv_setnv(newSVrv(rv,classname), nv);
6460 =for apidoc sv_setref_pvn
6462 Copies a string into a new SV, optionally blessing the SV. The length of the
6463 string must be specified with C<n>. The C<rv> argument will be upgraded to
6464 an RV. That RV will be modified to point to the new SV. The C<classname>
6465 argument indicates the package for the blessing. Set C<classname> to
6466 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6467 a reference count of 1.
6469 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6475 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6477 sv_setpvn(newSVrv(rv,classname), pv, n);
6482 =for apidoc sv_bless
6484 Blesses an SV into a specified package. The SV must be an RV. The package
6485 must be designated by its stash (see C<gv_stashpv()>). The reference count
6486 of the SV is unaffected.
6492 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6496 Perl_croak(aTHX_ "Can't bless non-reference value");
6498 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6499 if (SvREADONLY(tmpRef))
6500 Perl_croak(aTHX_ PL_no_modify);
6501 if (SvOBJECT(tmpRef)) {
6502 if (SvTYPE(tmpRef) != SVt_PVIO)
6504 SvREFCNT_dec(SvSTASH(tmpRef));
6507 SvOBJECT_on(tmpRef);
6508 if (SvTYPE(tmpRef) != SVt_PVIO)
6510 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6511 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6522 S_sv_unglob(pTHX_ SV *sv)
6526 assert(SvTYPE(sv) == SVt_PVGV);
6531 SvREFCNT_dec(GvSTASH(sv));
6532 GvSTASH(sv) = Nullhv;
6534 sv_unmagic(sv, '*');
6535 Safefree(GvNAME(sv));
6538 /* need to keep SvANY(sv) in the right arena */
6539 xpvmg = new_XPVMG();
6540 StructCopy(SvANY(sv), xpvmg, XPVMG);
6541 del_XPVGV(SvANY(sv));
6544 SvFLAGS(sv) &= ~SVTYPEMASK;
6545 SvFLAGS(sv) |= SVt_PVMG;
6549 =for apidoc sv_unref_flags
6551 Unsets the RV status of the SV, and decrements the reference count of
6552 whatever was being referenced by the RV. This can almost be thought of
6553 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6554 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6555 (otherwise the decrementing is conditional on the reference count being
6556 different from one or the reference being a readonly SV).
6563 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6567 if (SvWEAKREF(sv)) {
6575 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6577 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6578 sv_2mortal(rv); /* Schedule for freeing later */
6582 =for apidoc sv_unref
6584 Unsets the RV status of the SV, and decrements the reference count of
6585 whatever was being referenced by the RV. This can almost be thought of
6586 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6587 being zero. See C<SvROK_off>.
6593 Perl_sv_unref(pTHX_ SV *sv)
6595 sv_unref_flags(sv, 0);
6599 Perl_sv_taint(pTHX_ SV *sv)
6601 sv_magic((sv), Nullsv, 't', Nullch, 0);
6605 Perl_sv_untaint(pTHX_ SV *sv)
6607 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6608 MAGIC *mg = mg_find(sv, 't');
6615 Perl_sv_tainted(pTHX_ SV *sv)
6617 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6618 MAGIC *mg = mg_find(sv, 't');
6619 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6626 =for apidoc sv_setpviv
6628 Copies an integer into the given SV, also updating its string value.
6629 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6635 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6637 char buf[TYPE_CHARS(UV)];
6639 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6641 sv_setpvn(sv, ptr, ebuf - ptr);
6646 =for apidoc sv_setpviv_mg
6648 Like C<sv_setpviv>, but also handles 'set' magic.
6654 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6656 char buf[TYPE_CHARS(UV)];
6658 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6660 sv_setpvn(sv, ptr, ebuf - ptr);
6664 #if defined(PERL_IMPLICIT_CONTEXT)
6666 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6670 va_start(args, pat);
6671 sv_vsetpvf(sv, pat, &args);
6677 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6681 va_start(args, pat);
6682 sv_vsetpvf_mg(sv, pat, &args);
6688 =for apidoc sv_setpvf
6690 Processes its arguments like C<sprintf> and sets an SV to the formatted
6691 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6697 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6700 va_start(args, pat);
6701 sv_vsetpvf(sv, pat, &args);
6706 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6708 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6712 =for apidoc sv_setpvf_mg
6714 Like C<sv_setpvf>, but also handles 'set' magic.
6720 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6723 va_start(args, pat);
6724 sv_vsetpvf_mg(sv, pat, &args);
6729 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6731 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6735 #if defined(PERL_IMPLICIT_CONTEXT)
6737 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6741 va_start(args, pat);
6742 sv_vcatpvf(sv, pat, &args);
6747 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6751 va_start(args, pat);
6752 sv_vcatpvf_mg(sv, pat, &args);
6758 =for apidoc sv_catpvf
6760 Processes its arguments like C<sprintf> and appends the formatted output
6761 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6762 typically be called after calling this function to handle 'set' magic.
6768 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6771 va_start(args, pat);
6772 sv_vcatpvf(sv, pat, &args);
6777 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6779 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6783 =for apidoc sv_catpvf_mg
6785 Like C<sv_catpvf>, but also handles 'set' magic.
6791 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6794 va_start(args, pat);
6795 sv_vcatpvf_mg(sv, pat, &args);
6800 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6802 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6807 =for apidoc sv_vsetpvfn
6809 Works like C<vcatpvfn> but copies the text into the SV instead of
6816 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6818 sv_setpvn(sv, "", 0);
6819 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6823 S_expect_number(pTHX_ char** pattern)
6826 switch (**pattern) {
6827 case '1': case '2': case '3':
6828 case '4': case '5': case '6':
6829 case '7': case '8': case '9':
6830 while (isDIGIT(**pattern))
6831 var = var * 10 + (*(*pattern)++ - '0');
6835 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6838 =for apidoc sv_vcatpvfn
6840 Processes its arguments like C<vsprintf> and appends the formatted output
6841 to an SV. Uses an array of SVs if the C style variable argument list is
6842 missing (NULL). When running with taint checks enabled, indicates via
6843 C<maybe_tainted> if results are untrustworthy (often due to the use of
6850 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6857 static char nullstr[] = "(null)";
6860 /* no matter what, this is a string now */
6861 (void)SvPV_force(sv, origlen);
6863 /* special-case "", "%s", and "%_" */
6866 if (patlen == 2 && pat[0] == '%') {
6870 char *s = va_arg(*args, char*);
6871 sv_catpv(sv, s ? s : nullstr);
6873 else if (svix < svmax) {
6874 sv_catsv(sv, *svargs);
6875 if (DO_UTF8(*svargs))
6881 argsv = va_arg(*args, SV*);
6882 sv_catsv(sv, argsv);
6887 /* See comment on '_' below */
6892 patend = (char*)pat + patlen;
6893 for (p = (char*)pat; p < patend; p = q) {
6896 bool vectorize = FALSE;
6897 bool vectorarg = FALSE;
6898 bool vec_utf = FALSE;
6904 bool has_precis = FALSE;
6906 bool is_utf = FALSE;
6909 U8 utf8buf[UTF8_MAXLEN+1];
6910 STRLEN esignlen = 0;
6912 char *eptr = Nullch;
6914 /* Times 4: a decimal digit takes more than 3 binary digits.
6915 * NV_DIG: mantissa takes than many decimal digits.
6916 * Plus 32: Playing safe. */
6917 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6918 /* large enough for "%#.#f" --chip */
6919 /* what about long double NVs? --jhi */
6922 U8 *vecstr = Null(U8*);
6934 STRLEN dotstrlen = 1;
6935 I32 efix = 0; /* explicit format parameter index */
6936 I32 ewix = 0; /* explicit width index */
6937 I32 epix = 0; /* explicit precision index */
6938 I32 evix = 0; /* explicit vector index */
6939 bool asterisk = FALSE;
6941 /* echo everything up to the next format specification */
6942 for (q = p; q < patend && *q != '%'; ++q) ;
6944 sv_catpvn(sv, p, q - p);
6951 We allow format specification elements in this order:
6952 \d+\$ explicit format parameter index
6954 \*?(\d+\$)?v vector with optional (optionally specified) arg
6955 \d+|\*(\d+\$)? width using optional (optionally specified) arg
6956 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
6958 [%bcdefginopsux_DFOUX] format (mandatory)
6960 if (EXPECT_NUMBER(q, width)) {
7001 if (EXPECT_NUMBER(q, ewix))
7010 if ((vectorarg = asterisk)) {
7020 EXPECT_NUMBER(q, width);
7025 vecsv = va_arg(*args, SV*);
7027 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7028 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7029 dotstr = SvPVx(vecsv, dotstrlen);
7034 vecsv = va_arg(*args, SV*);
7035 vecstr = (U8*)SvPVx(vecsv,veclen);
7036 vec_utf = DO_UTF8(vecsv);
7038 else if (efix ? efix <= svmax : svix < svmax) {
7039 vecsv = svargs[efix ? efix-1 : svix++];
7040 vecstr = (U8*)SvPVx(vecsv,veclen);
7041 vec_utf = DO_UTF8(vecsv);
7051 i = va_arg(*args, int);
7053 i = (ewix ? ewix <= svmax : svix < svmax) ?
7054 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7056 width = (i < 0) ? -i : i;
7066 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7069 i = va_arg(*args, int);
7071 i = (ewix ? ewix <= svmax : svix < svmax)
7072 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7073 precis = (i < 0) ? 0 : i;
7078 precis = precis * 10 + (*q++ - '0');
7086 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7097 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7098 if (*(q + 1) == 'l') { /* lld, llf */
7121 argsv = (efix ? efix <= svmax : svix < svmax) ?
7122 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7129 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7130 if ((uv > 255 || (!UTF8_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTE) {
7131 eptr = (char*)utf8buf;
7132 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7144 eptr = va_arg(*args, char*);
7146 #ifdef MACOS_TRADITIONAL
7147 /* On MacOS, %#s format is used for Pascal strings */
7152 elen = strlen(eptr);
7155 elen = sizeof nullstr - 1;
7159 eptr = SvPVx(argsv, elen);
7160 if (DO_UTF8(argsv)) {
7161 if (has_precis && precis < elen) {
7163 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7166 if (width) { /* fudge width (can't fudge elen) */
7167 width += elen - sv_len_utf8(argsv);
7176 * The "%_" hack might have to be changed someday,
7177 * if ISO or ANSI decide to use '_' for something.
7178 * So we keep it hidden from users' code.
7182 argsv = va_arg(*args, SV*);
7183 eptr = SvPVx(argsv, elen);
7189 if (has_precis && elen > precis)
7198 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7216 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7226 case 'h': iv = (short)va_arg(*args, int); break;
7227 default: iv = va_arg(*args, int); break;
7228 case 'l': iv = va_arg(*args, long); break;
7229 case 'V': iv = va_arg(*args, IV); break;
7231 case 'q': iv = va_arg(*args, Quad_t); break;
7238 case 'h': iv = (short)iv; break;
7240 case 'l': iv = (long)iv; break;
7243 case 'q': iv = (Quad_t)iv; break;
7250 esignbuf[esignlen++] = plus;
7254 esignbuf[esignlen++] = '-';
7296 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7306 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7307 default: uv = va_arg(*args, unsigned); break;
7308 case 'l': uv = va_arg(*args, unsigned long); break;
7309 case 'V': uv = va_arg(*args, UV); break;
7311 case 'q': uv = va_arg(*args, Quad_t); break;
7318 case 'h': uv = (unsigned short)uv; break;
7320 case 'l': uv = (unsigned long)uv; break;
7323 case 'q': uv = (Quad_t)uv; break;
7329 eptr = ebuf + sizeof ebuf;
7335 p = (char*)((c == 'X')
7336 ? "0123456789ABCDEF" : "0123456789abcdef");
7342 esignbuf[esignlen++] = '0';
7343 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7349 *--eptr = '0' + dig;
7351 if (alt && *eptr != '0')
7357 *--eptr = '0' + dig;
7360 esignbuf[esignlen++] = '0';
7361 esignbuf[esignlen++] = 'b';
7364 default: /* it had better be ten or less */
7365 #if defined(PERL_Y2KWARN)
7366 if (ckWARN(WARN_Y2K)) {
7368 char *s = SvPV(sv,n);
7369 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7370 && (n == 2 || !isDIGIT(s[n-3])))
7372 Perl_warner(aTHX_ WARN_Y2K,
7373 "Possible Y2K bug: %%%c %s",
7374 c, "format string following '19'");
7380 *--eptr = '0' + dig;
7381 } while (uv /= base);
7384 elen = (ebuf + sizeof ebuf) - eptr;
7387 zeros = precis - elen;
7388 else if (precis == 0 && elen == 1 && *eptr == '0')
7393 /* FLOATING POINT */
7396 c = 'f'; /* maybe %F isn't supported here */
7402 /* This is evil, but floating point is even more evil */
7405 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7408 if (c != 'e' && c != 'E') {
7410 (void)Perl_frexp(nv, &i);
7411 if (i == PERL_INT_MIN)
7412 Perl_die(aTHX_ "panic: frexp");
7414 need = BIT_DIGITS(i);
7416 need += has_precis ? precis : 6; /* known default */
7420 need += 20; /* fudge factor */
7421 if (PL_efloatsize < need) {
7422 Safefree(PL_efloatbuf);
7423 PL_efloatsize = need + 20; /* more fudge */
7424 New(906, PL_efloatbuf, PL_efloatsize, char);
7425 PL_efloatbuf[0] = '\0';
7428 eptr = ebuf + sizeof ebuf;
7431 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7433 /* Copy the one or more characters in a long double
7434 * format before the 'base' ([efgEFG]) character to
7435 * the format string. */
7436 static char const prifldbl[] = PERL_PRIfldbl;
7437 char const *p = prifldbl + sizeof(prifldbl) - 3;
7438 while (p >= prifldbl) { *--eptr = *p--; }
7443 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7448 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7460 /* No taint. Otherwise we are in the strange situation
7461 * where printf() taints but print($float) doesn't.
7463 (void)sprintf(PL_efloatbuf, eptr, nv);
7465 eptr = PL_efloatbuf;
7466 elen = strlen(PL_efloatbuf);
7473 i = SvCUR(sv) - origlen;
7476 case 'h': *(va_arg(*args, short*)) = i; break;
7477 default: *(va_arg(*args, int*)) = i; break;
7478 case 'l': *(va_arg(*args, long*)) = i; break;
7479 case 'V': *(va_arg(*args, IV*)) = i; break;
7481 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7486 sv_setuv_mg(argsv, (UV)i);
7487 continue; /* not "break" */
7494 if (!args && ckWARN(WARN_PRINTF) &&
7495 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7496 SV *msg = sv_newmortal();
7497 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7498 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7501 Perl_sv_catpvf(aTHX_ msg,
7502 "\"%%%c\"", c & 0xFF);
7504 Perl_sv_catpvf(aTHX_ msg,
7505 "\"%%\\%03"UVof"\"",
7508 sv_catpv(msg, "end of string");
7509 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7512 /* output mangled stuff ... */
7518 /* ... right here, because formatting flags should not apply */
7519 SvGROW(sv, SvCUR(sv) + elen + 1);
7521 Copy(eptr, p, elen, char);
7524 SvCUR(sv) = p - SvPVX(sv);
7525 continue; /* not "break" */
7528 have = esignlen + zeros + elen;
7529 need = (have > width ? have : width);
7532 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7534 if (esignlen && fill == '0') {
7535 for (i = 0; i < esignlen; i++)
7539 memset(p, fill, gap);
7542 if (esignlen && fill != '0') {
7543 for (i = 0; i < esignlen; i++)
7547 for (i = zeros; i; i--)
7551 Copy(eptr, p, elen, char);
7555 memset(p, ' ', gap);
7560 Copy(dotstr, p, dotstrlen, char);
7564 vectorize = FALSE; /* done iterating over vecstr */
7569 SvCUR(sv) = p - SvPVX(sv);
7577 #if defined(USE_ITHREADS)
7579 #if defined(USE_THREADS)
7580 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7583 #ifndef GpREFCNT_inc
7584 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7588 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7589 #define av_dup(s) (AV*)sv_dup((SV*)s)
7590 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7591 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7592 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7593 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7594 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7595 #define io_dup(s) (IO*)sv_dup((SV*)s)
7596 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7597 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7598 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7599 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7600 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7603 Perl_re_dup(pTHX_ REGEXP *r)
7605 /* XXX fix when pmop->op_pmregexp becomes shared */
7606 return ReREFCNT_inc(r);
7610 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7614 return (PerlIO*)NULL;
7616 /* look for it in the table first */
7617 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7621 /* create anew and remember what it is */
7622 ret = PerlIO_fdupopen(aTHX_ fp);
7623 ptr_table_store(PL_ptr_table, fp, ret);
7628 Perl_dirp_dup(pTHX_ DIR *dp)
7637 Perl_gp_dup(pTHX_ GP *gp)
7642 /* look for it in the table first */
7643 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7647 /* create anew and remember what it is */
7648 Newz(0, ret, 1, GP);
7649 ptr_table_store(PL_ptr_table, gp, ret);
7652 ret->gp_refcnt = 0; /* must be before any other dups! */
7653 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7654 ret->gp_io = io_dup_inc(gp->gp_io);
7655 ret->gp_form = cv_dup_inc(gp->gp_form);
7656 ret->gp_av = av_dup_inc(gp->gp_av);
7657 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7658 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7659 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7660 ret->gp_cvgen = gp->gp_cvgen;
7661 ret->gp_flags = gp->gp_flags;
7662 ret->gp_line = gp->gp_line;
7663 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7668 Perl_mg_dup(pTHX_ MAGIC *mg)
7670 MAGIC *mgret = (MAGIC*)NULL;
7673 return (MAGIC*)NULL;
7674 /* look for it in the table first */
7675 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7679 for (; mg; mg = mg->mg_moremagic) {
7681 Newz(0, nmg, 1, MAGIC);
7685 mgprev->mg_moremagic = nmg;
7686 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7687 nmg->mg_private = mg->mg_private;
7688 nmg->mg_type = mg->mg_type;
7689 nmg->mg_flags = mg->mg_flags;
7690 if (mg->mg_type == 'r') {
7691 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7694 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7695 ? sv_dup_inc(mg->mg_obj)
7696 : sv_dup(mg->mg_obj);
7698 nmg->mg_len = mg->mg_len;
7699 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7700 if (mg->mg_ptr && mg->mg_type != 'g') {
7701 if (mg->mg_len >= 0) {
7702 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7703 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7704 AMT *amtp = (AMT*)mg->mg_ptr;
7705 AMT *namtp = (AMT*)nmg->mg_ptr;
7707 for (i = 1; i < NofAMmeth; i++) {
7708 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7712 else if (mg->mg_len == HEf_SVKEY)
7713 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7721 Perl_ptr_table_new(pTHX)
7724 Newz(0, tbl, 1, PTR_TBL_t);
7727 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7732 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7734 PTR_TBL_ENT_t *tblent;
7735 UV hash = PTR2UV(sv);
7737 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7738 for (; tblent; tblent = tblent->next) {
7739 if (tblent->oldval == sv)
7740 return tblent->newval;
7746 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7748 PTR_TBL_ENT_t *tblent, **otblent;
7749 /* XXX this may be pessimal on platforms where pointers aren't good
7750 * hash values e.g. if they grow faster in the most significant
7752 UV hash = PTR2UV(oldv);
7756 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7757 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7758 if (tblent->oldval == oldv) {
7759 tblent->newval = newv;
7764 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7765 tblent->oldval = oldv;
7766 tblent->newval = newv;
7767 tblent->next = *otblent;
7770 if (i && tbl->tbl_items > tbl->tbl_max)
7771 ptr_table_split(tbl);
7775 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7777 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7778 UV oldsize = tbl->tbl_max + 1;
7779 UV newsize = oldsize * 2;
7782 Renew(ary, newsize, PTR_TBL_ENT_t*);
7783 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7784 tbl->tbl_max = --newsize;
7786 for (i=0; i < oldsize; i++, ary++) {
7787 PTR_TBL_ENT_t **curentp, **entp, *ent;
7790 curentp = ary + oldsize;
7791 for (entp = ary, ent = *ary; ent; ent = *entp) {
7792 if ((newsize & PTR2UV(ent->oldval)) != i) {
7794 ent->next = *curentp;
7805 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7807 register PTR_TBL_ENT_t **array;
7808 register PTR_TBL_ENT_t *entry;
7809 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7813 if (!tbl || !tbl->tbl_items) {
7817 array = tbl->tbl_ary;
7824 entry = entry->next;
7828 if (++riter > max) {
7831 entry = array[riter];
7839 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7844 ptr_table_clear(tbl);
7845 Safefree(tbl->tbl_ary);
7854 S_gv_share(pTHX_ SV *sstr)
7857 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7859 if (GvIO(gv) || GvFORM(gv)) {
7860 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
7862 else if (!GvCV(gv)) {
7866 /* CvPADLISTs cannot be shared */
7867 if (!CvXSUB(GvCV(gv))) {
7872 if (!GvSHARED(gv)) {
7874 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
7875 HvNAME(GvSTASH(gv)), GvNAME(gv));
7881 * write attempts will die with
7882 * "Modification of a read-only value attempted"
7888 SvREADONLY_on(GvSV(gv));
7895 SvREADONLY_on(GvAV(gv));
7902 SvREADONLY_on(GvAV(gv));
7905 return sstr; /* he_dup() will SvREFCNT_inc() */
7909 Perl_sv_dup(pTHX_ SV *sstr)
7913 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7915 /* look for it in the table first */
7916 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7920 /* create anew and remember what it is */
7922 ptr_table_store(PL_ptr_table, sstr, dstr);
7925 SvFLAGS(dstr) = SvFLAGS(sstr);
7926 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7927 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7930 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7931 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7932 PL_watch_pvx, SvPVX(sstr));
7935 switch (SvTYPE(sstr)) {
7940 SvANY(dstr) = new_XIV();
7941 SvIVX(dstr) = SvIVX(sstr);
7944 SvANY(dstr) = new_XNV();
7945 SvNVX(dstr) = SvNVX(sstr);
7948 SvANY(dstr) = new_XRV();
7949 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7952 SvANY(dstr) = new_XPV();
7953 SvCUR(dstr) = SvCUR(sstr);
7954 SvLEN(dstr) = SvLEN(sstr);
7956 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7957 else if (SvPVX(sstr) && SvLEN(sstr))
7958 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7960 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7963 SvANY(dstr) = new_XPVIV();
7964 SvCUR(dstr) = SvCUR(sstr);
7965 SvLEN(dstr) = SvLEN(sstr);
7966 SvIVX(dstr) = SvIVX(sstr);
7968 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7969 else if (SvPVX(sstr) && SvLEN(sstr))
7970 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7972 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7975 SvANY(dstr) = new_XPVNV();
7976 SvCUR(dstr) = SvCUR(sstr);
7977 SvLEN(dstr) = SvLEN(sstr);
7978 SvIVX(dstr) = SvIVX(sstr);
7979 SvNVX(dstr) = SvNVX(sstr);
7981 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7982 else if (SvPVX(sstr) && SvLEN(sstr))
7983 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7985 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7988 SvANY(dstr) = new_XPVMG();
7989 SvCUR(dstr) = SvCUR(sstr);
7990 SvLEN(dstr) = SvLEN(sstr);
7991 SvIVX(dstr) = SvIVX(sstr);
7992 SvNVX(dstr) = SvNVX(sstr);
7993 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7994 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7996 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7997 else if (SvPVX(sstr) && SvLEN(sstr))
7998 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8000 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8003 SvANY(dstr) = new_XPVBM();
8004 SvCUR(dstr) = SvCUR(sstr);
8005 SvLEN(dstr) = SvLEN(sstr);
8006 SvIVX(dstr) = SvIVX(sstr);
8007 SvNVX(dstr) = SvNVX(sstr);
8008 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8009 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8011 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8012 else if (SvPVX(sstr) && SvLEN(sstr))
8013 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8015 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8016 BmRARE(dstr) = BmRARE(sstr);
8017 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8018 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8021 SvANY(dstr) = new_XPVLV();
8022 SvCUR(dstr) = SvCUR(sstr);
8023 SvLEN(dstr) = SvLEN(sstr);
8024 SvIVX(dstr) = SvIVX(sstr);
8025 SvNVX(dstr) = SvNVX(sstr);
8026 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8027 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8029 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8030 else if (SvPVX(sstr) && SvLEN(sstr))
8031 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8033 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8034 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8035 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8036 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8037 LvTYPE(dstr) = LvTYPE(sstr);
8040 if (GvSHARED((GV*)sstr)) {
8042 if ((share = gv_share(sstr))) {
8046 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8047 HvNAME(GvSTASH(share)), GvNAME(share));
8052 SvANY(dstr) = new_XPVGV();
8053 SvCUR(dstr) = SvCUR(sstr);
8054 SvLEN(dstr) = SvLEN(sstr);
8055 SvIVX(dstr) = SvIVX(sstr);
8056 SvNVX(dstr) = SvNVX(sstr);
8057 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8058 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8060 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8061 else if (SvPVX(sstr) && SvLEN(sstr))
8062 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8064 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8065 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8066 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8067 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8068 GvFLAGS(dstr) = GvFLAGS(sstr);
8069 GvGP(dstr) = gp_dup(GvGP(sstr));
8070 (void)GpREFCNT_inc(GvGP(dstr));
8073 SvANY(dstr) = new_XPVIO();
8074 SvCUR(dstr) = SvCUR(sstr);
8075 SvLEN(dstr) = SvLEN(sstr);
8076 SvIVX(dstr) = SvIVX(sstr);
8077 SvNVX(dstr) = SvNVX(sstr);
8078 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8079 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8081 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8082 else if (SvPVX(sstr) && SvLEN(sstr))
8083 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8085 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8086 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8087 if (IoOFP(sstr) == IoIFP(sstr))
8088 IoOFP(dstr) = IoIFP(dstr);
8090 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8091 /* PL_rsfp_filters entries have fake IoDIRP() */
8092 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8093 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8095 IoDIRP(dstr) = IoDIRP(sstr);
8096 IoLINES(dstr) = IoLINES(sstr);
8097 IoPAGE(dstr) = IoPAGE(sstr);
8098 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8099 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8100 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8101 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8102 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8103 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8104 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8105 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8106 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8107 IoTYPE(dstr) = IoTYPE(sstr);
8108 IoFLAGS(dstr) = IoFLAGS(sstr);
8111 SvANY(dstr) = new_XPVAV();
8112 SvCUR(dstr) = SvCUR(sstr);
8113 SvLEN(dstr) = SvLEN(sstr);
8114 SvIVX(dstr) = SvIVX(sstr);
8115 SvNVX(dstr) = SvNVX(sstr);
8116 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8117 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8118 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8119 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8120 if (AvARRAY((AV*)sstr)) {
8121 SV **dst_ary, **src_ary;
8122 SSize_t items = AvFILLp((AV*)sstr) + 1;
8124 src_ary = AvARRAY((AV*)sstr);
8125 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8126 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8127 SvPVX(dstr) = (char*)dst_ary;
8128 AvALLOC((AV*)dstr) = dst_ary;
8129 if (AvREAL((AV*)sstr)) {
8131 *dst_ary++ = sv_dup_inc(*src_ary++);
8135 *dst_ary++ = sv_dup(*src_ary++);
8137 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8138 while (items-- > 0) {
8139 *dst_ary++ = &PL_sv_undef;
8143 SvPVX(dstr) = Nullch;
8144 AvALLOC((AV*)dstr) = (SV**)NULL;
8148 SvANY(dstr) = new_XPVHV();
8149 SvCUR(dstr) = SvCUR(sstr);
8150 SvLEN(dstr) = SvLEN(sstr);
8151 SvIVX(dstr) = SvIVX(sstr);
8152 SvNVX(dstr) = SvNVX(sstr);
8153 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8154 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8155 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8156 if (HvARRAY((HV*)sstr)) {
8158 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8159 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8160 Newz(0, dxhv->xhv_array,
8161 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8162 while (i <= sxhv->xhv_max) {
8163 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8164 !!HvSHAREKEYS(sstr));
8167 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8170 SvPVX(dstr) = Nullch;
8171 HvEITER((HV*)dstr) = (HE*)NULL;
8173 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8174 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8177 SvANY(dstr) = new_XPVFM();
8178 FmLINES(dstr) = FmLINES(sstr);
8182 SvANY(dstr) = new_XPVCV();
8184 SvCUR(dstr) = SvCUR(sstr);
8185 SvLEN(dstr) = SvLEN(sstr);
8186 SvIVX(dstr) = SvIVX(sstr);
8187 SvNVX(dstr) = SvNVX(sstr);
8188 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8189 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8190 if (SvPVX(sstr) && SvLEN(sstr))
8191 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8193 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8194 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8195 CvSTART(dstr) = CvSTART(sstr);
8196 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8197 CvXSUB(dstr) = CvXSUB(sstr);
8198 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8199 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
8200 CvDEPTH(dstr) = CvDEPTH(sstr);
8201 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8202 /* XXX padlists are real, but pretend to be not */
8203 AvREAL_on(CvPADLIST(sstr));
8204 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8205 AvREAL_off(CvPADLIST(sstr));
8206 AvREAL_off(CvPADLIST(dstr));
8209 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8210 if (!CvANON(sstr) || CvCLONED(sstr))
8211 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8213 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8214 CvFLAGS(dstr) = CvFLAGS(sstr);
8217 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8221 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8228 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8233 return (PERL_CONTEXT*)NULL;
8235 /* look for it in the table first */
8236 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8240 /* create anew and remember what it is */
8241 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8242 ptr_table_store(PL_ptr_table, cxs, ncxs);
8245 PERL_CONTEXT *cx = &cxs[ix];
8246 PERL_CONTEXT *ncx = &ncxs[ix];
8247 ncx->cx_type = cx->cx_type;
8248 if (CxTYPE(cx) == CXt_SUBST) {
8249 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8252 ncx->blk_oldsp = cx->blk_oldsp;
8253 ncx->blk_oldcop = cx->blk_oldcop;
8254 ncx->blk_oldretsp = cx->blk_oldretsp;
8255 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8256 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8257 ncx->blk_oldpm = cx->blk_oldpm;
8258 ncx->blk_gimme = cx->blk_gimme;
8259 switch (CxTYPE(cx)) {
8261 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8262 ? cv_dup_inc(cx->blk_sub.cv)
8263 : cv_dup(cx->blk_sub.cv));
8264 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8265 ? av_dup_inc(cx->blk_sub.argarray)
8267 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
8268 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8269 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8270 ncx->blk_sub.lval = cx->blk_sub.lval;
8273 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8274 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8275 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8276 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8277 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8280 ncx->blk_loop.label = cx->blk_loop.label;
8281 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8282 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8283 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8284 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8285 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8286 ? cx->blk_loop.iterdata
8287 : gv_dup((GV*)cx->blk_loop.iterdata));
8288 ncx->blk_loop.oldcurpad
8289 = (SV**)ptr_table_fetch(PL_ptr_table,
8290 cx->blk_loop.oldcurpad);
8291 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8292 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8293 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8294 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8295 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8298 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8299 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8300 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8301 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8314 Perl_si_dup(pTHX_ PERL_SI *si)
8319 return (PERL_SI*)NULL;
8321 /* look for it in the table first */
8322 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8326 /* create anew and remember what it is */
8327 Newz(56, nsi, 1, PERL_SI);
8328 ptr_table_store(PL_ptr_table, si, nsi);
8330 nsi->si_stack = av_dup_inc(si->si_stack);
8331 nsi->si_cxix = si->si_cxix;
8332 nsi->si_cxmax = si->si_cxmax;
8333 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8334 nsi->si_type = si->si_type;
8335 nsi->si_prev = si_dup(si->si_prev);
8336 nsi->si_next = si_dup(si->si_next);
8337 nsi->si_markoff = si->si_markoff;
8342 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8343 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8344 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8345 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8346 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8347 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8348 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8349 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8350 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8351 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8352 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8353 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8356 #define pv_dup_inc(p) SAVEPV(p)
8357 #define pv_dup(p) SAVEPV(p)
8358 #define svp_dup_inc(p,pp) any_dup(p,pp)
8361 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8368 /* look for it in the table first */
8369 ret = ptr_table_fetch(PL_ptr_table, v);
8373 /* see if it is part of the interpreter structure */
8374 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8375 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8383 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8385 ANY *ss = proto_perl->Tsavestack;
8386 I32 ix = proto_perl->Tsavestack_ix;
8387 I32 max = proto_perl->Tsavestack_max;
8400 void (*dptr) (void*);
8401 void (*dxptr) (pTHXo_ void*);
8404 Newz(54, nss, max, ANY);
8410 case SAVEt_ITEM: /* normal string */
8411 sv = (SV*)POPPTR(ss,ix);
8412 TOPPTR(nss,ix) = sv_dup_inc(sv);
8413 sv = (SV*)POPPTR(ss,ix);
8414 TOPPTR(nss,ix) = sv_dup_inc(sv);
8416 case SAVEt_SV: /* scalar reference */
8417 sv = (SV*)POPPTR(ss,ix);
8418 TOPPTR(nss,ix) = sv_dup_inc(sv);
8419 gv = (GV*)POPPTR(ss,ix);
8420 TOPPTR(nss,ix) = gv_dup_inc(gv);
8422 case SAVEt_GENERIC_PVREF: /* generic char* */
8423 c = (char*)POPPTR(ss,ix);
8424 TOPPTR(nss,ix) = pv_dup(c);
8425 ptr = POPPTR(ss,ix);
8426 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8428 case SAVEt_GENERIC_SVREF: /* generic sv */
8429 case SAVEt_SVREF: /* scalar reference */
8430 sv = (SV*)POPPTR(ss,ix);
8431 TOPPTR(nss,ix) = sv_dup_inc(sv);
8432 ptr = POPPTR(ss,ix);
8433 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8435 case SAVEt_AV: /* array reference */
8436 av = (AV*)POPPTR(ss,ix);
8437 TOPPTR(nss,ix) = av_dup_inc(av);
8438 gv = (GV*)POPPTR(ss,ix);
8439 TOPPTR(nss,ix) = gv_dup(gv);
8441 case SAVEt_HV: /* hash reference */
8442 hv = (HV*)POPPTR(ss,ix);
8443 TOPPTR(nss,ix) = hv_dup_inc(hv);
8444 gv = (GV*)POPPTR(ss,ix);
8445 TOPPTR(nss,ix) = gv_dup(gv);
8447 case SAVEt_INT: /* int reference */
8448 ptr = POPPTR(ss,ix);
8449 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8450 intval = (int)POPINT(ss,ix);
8451 TOPINT(nss,ix) = intval;
8453 case SAVEt_LONG: /* long reference */
8454 ptr = POPPTR(ss,ix);
8455 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8456 longval = (long)POPLONG(ss,ix);
8457 TOPLONG(nss,ix) = longval;
8459 case SAVEt_I32: /* I32 reference */
8460 case SAVEt_I16: /* I16 reference */
8461 case SAVEt_I8: /* I8 reference */
8462 ptr = POPPTR(ss,ix);
8463 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8467 case SAVEt_IV: /* IV reference */
8468 ptr = POPPTR(ss,ix);
8469 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8473 case SAVEt_SPTR: /* SV* reference */
8474 ptr = POPPTR(ss,ix);
8475 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8476 sv = (SV*)POPPTR(ss,ix);
8477 TOPPTR(nss,ix) = sv_dup(sv);
8479 case SAVEt_VPTR: /* random* reference */
8480 ptr = POPPTR(ss,ix);
8481 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8482 ptr = POPPTR(ss,ix);
8483 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8485 case SAVEt_PPTR: /* char* reference */
8486 ptr = POPPTR(ss,ix);
8487 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8488 c = (char*)POPPTR(ss,ix);
8489 TOPPTR(nss,ix) = pv_dup(c);
8491 case SAVEt_HPTR: /* HV* reference */
8492 ptr = POPPTR(ss,ix);
8493 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8494 hv = (HV*)POPPTR(ss,ix);
8495 TOPPTR(nss,ix) = hv_dup(hv);
8497 case SAVEt_APTR: /* AV* reference */
8498 ptr = POPPTR(ss,ix);
8499 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8500 av = (AV*)POPPTR(ss,ix);
8501 TOPPTR(nss,ix) = av_dup(av);
8504 gv = (GV*)POPPTR(ss,ix);
8505 TOPPTR(nss,ix) = gv_dup(gv);
8507 case SAVEt_GP: /* scalar reference */
8508 gp = (GP*)POPPTR(ss,ix);
8509 TOPPTR(nss,ix) = gp = gp_dup(gp);
8510 (void)GpREFCNT_inc(gp);
8511 gv = (GV*)POPPTR(ss,ix);
8512 TOPPTR(nss,ix) = gv_dup_inc(c);
8513 c = (char*)POPPTR(ss,ix);
8514 TOPPTR(nss,ix) = pv_dup(c);
8521 sv = (SV*)POPPTR(ss,ix);
8522 TOPPTR(nss,ix) = sv_dup_inc(sv);
8525 ptr = POPPTR(ss,ix);
8526 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8527 /* these are assumed to be refcounted properly */
8528 switch (((OP*)ptr)->op_type) {
8535 TOPPTR(nss,ix) = ptr;
8540 TOPPTR(nss,ix) = Nullop;
8545 TOPPTR(nss,ix) = Nullop;
8548 c = (char*)POPPTR(ss,ix);
8549 TOPPTR(nss,ix) = pv_dup_inc(c);
8552 longval = POPLONG(ss,ix);
8553 TOPLONG(nss,ix) = longval;
8556 hv = (HV*)POPPTR(ss,ix);
8557 TOPPTR(nss,ix) = hv_dup_inc(hv);
8558 c = (char*)POPPTR(ss,ix);
8559 TOPPTR(nss,ix) = pv_dup_inc(c);
8563 case SAVEt_DESTRUCTOR:
8564 ptr = POPPTR(ss,ix);
8565 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8566 dptr = POPDPTR(ss,ix);
8567 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8569 case SAVEt_DESTRUCTOR_X:
8570 ptr = POPPTR(ss,ix);
8571 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8572 dxptr = POPDXPTR(ss,ix);
8573 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8575 case SAVEt_REGCONTEXT:
8581 case SAVEt_STACK_POS: /* Position on Perl stack */
8585 case SAVEt_AELEM: /* array element */
8586 sv = (SV*)POPPTR(ss,ix);
8587 TOPPTR(nss,ix) = sv_dup_inc(sv);
8590 av = (AV*)POPPTR(ss,ix);
8591 TOPPTR(nss,ix) = av_dup_inc(av);
8593 case SAVEt_HELEM: /* hash element */
8594 sv = (SV*)POPPTR(ss,ix);
8595 TOPPTR(nss,ix) = sv_dup_inc(sv);
8596 sv = (SV*)POPPTR(ss,ix);
8597 TOPPTR(nss,ix) = sv_dup_inc(sv);
8598 hv = (HV*)POPPTR(ss,ix);
8599 TOPPTR(nss,ix) = hv_dup_inc(hv);
8602 ptr = POPPTR(ss,ix);
8603 TOPPTR(nss,ix) = ptr;
8610 av = (AV*)POPPTR(ss,ix);
8611 TOPPTR(nss,ix) = av_dup(av);
8614 longval = (long)POPLONG(ss,ix);
8615 TOPLONG(nss,ix) = longval;
8616 ptr = POPPTR(ss,ix);
8617 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8618 sv = (SV*)POPPTR(ss,ix);
8619 TOPPTR(nss,ix) = sv_dup(sv);
8622 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8634 perl_clone(PerlInterpreter *proto_perl, UV flags)
8637 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8640 #ifdef PERL_IMPLICIT_SYS
8641 return perl_clone_using(proto_perl, flags,
8643 proto_perl->IMemShared,
8644 proto_perl->IMemParse,
8654 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8655 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8656 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8657 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8658 struct IPerlDir* ipD, struct IPerlSock* ipS,
8659 struct IPerlProc* ipP)
8661 /* XXX many of the string copies here can be optimized if they're
8662 * constants; they need to be allocated as common memory and just
8663 * their pointers copied. */
8667 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8669 PERL_SET_THX(pPerl);
8670 # else /* !PERL_OBJECT */
8671 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8672 PERL_SET_THX(my_perl);
8675 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8681 # else /* !DEBUGGING */
8682 Zero(my_perl, 1, PerlInterpreter);
8683 # endif /* DEBUGGING */
8687 PL_MemShared = ipMS;
8695 # endif /* PERL_OBJECT */
8696 #else /* !PERL_IMPLICIT_SYS */
8698 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8699 PERL_SET_THX(my_perl);
8702 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8708 # else /* !DEBUGGING */
8709 Zero(my_perl, 1, PerlInterpreter);
8710 # endif /* DEBUGGING */
8711 #endif /* PERL_IMPLICIT_SYS */
8714 PL_xiv_arenaroot = NULL;
8716 PL_xnv_arenaroot = NULL;
8718 PL_xrv_arenaroot = NULL;
8720 PL_xpv_arenaroot = NULL;
8722 PL_xpviv_arenaroot = NULL;
8723 PL_xpviv_root = NULL;
8724 PL_xpvnv_arenaroot = NULL;
8725 PL_xpvnv_root = NULL;
8726 PL_xpvcv_arenaroot = NULL;
8727 PL_xpvcv_root = NULL;
8728 PL_xpvav_arenaroot = NULL;
8729 PL_xpvav_root = NULL;
8730 PL_xpvhv_arenaroot = NULL;
8731 PL_xpvhv_root = NULL;
8732 PL_xpvmg_arenaroot = NULL;
8733 PL_xpvmg_root = NULL;
8734 PL_xpvlv_arenaroot = NULL;
8735 PL_xpvlv_root = NULL;
8736 PL_xpvbm_arenaroot = NULL;
8737 PL_xpvbm_root = NULL;
8738 PL_he_arenaroot = NULL;
8740 PL_nice_chunk = NULL;
8741 PL_nice_chunk_size = 0;
8744 PL_sv_root = Nullsv;
8745 PL_sv_arenaroot = Nullsv;
8747 PL_debug = proto_perl->Idebug;
8749 /* create SV map for pointer relocation */
8750 PL_ptr_table = ptr_table_new();
8752 /* initialize these special pointers as early as possible */
8753 SvANY(&PL_sv_undef) = NULL;
8754 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8755 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8756 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8759 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8761 SvANY(&PL_sv_no) = new_XPVNV();
8763 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8764 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8765 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8766 SvCUR(&PL_sv_no) = 0;
8767 SvLEN(&PL_sv_no) = 1;
8768 SvNVX(&PL_sv_no) = 0;
8769 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8772 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8774 SvANY(&PL_sv_yes) = new_XPVNV();
8776 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8777 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8778 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8779 SvCUR(&PL_sv_yes) = 1;
8780 SvLEN(&PL_sv_yes) = 2;
8781 SvNVX(&PL_sv_yes) = 1;
8782 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8784 /* create shared string table */
8785 PL_strtab = newHV();
8786 HvSHAREKEYS_off(PL_strtab);
8787 hv_ksplit(PL_strtab, 512);
8788 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8790 PL_compiling = proto_perl->Icompiling;
8791 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8792 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8793 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8794 if (!specialWARN(PL_compiling.cop_warnings))
8795 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8796 if (!specialCopIO(PL_compiling.cop_io))
8797 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8798 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8800 /* pseudo environmental stuff */
8801 PL_origargc = proto_perl->Iorigargc;
8803 New(0, PL_origargv, i+1, char*);
8804 PL_origargv[i] = '\0';
8806 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8808 PL_envgv = gv_dup(proto_perl->Ienvgv);
8809 PL_incgv = gv_dup(proto_perl->Iincgv);
8810 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8811 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8812 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8813 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8816 PL_minus_c = proto_perl->Iminus_c;
8817 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8818 PL_localpatches = proto_perl->Ilocalpatches;
8819 PL_splitstr = proto_perl->Isplitstr;
8820 PL_preprocess = proto_perl->Ipreprocess;
8821 PL_minus_n = proto_perl->Iminus_n;
8822 PL_minus_p = proto_perl->Iminus_p;
8823 PL_minus_l = proto_perl->Iminus_l;
8824 PL_minus_a = proto_perl->Iminus_a;
8825 PL_minus_F = proto_perl->Iminus_F;
8826 PL_doswitches = proto_perl->Idoswitches;
8827 PL_dowarn = proto_perl->Idowarn;
8828 PL_doextract = proto_perl->Idoextract;
8829 PL_sawampersand = proto_perl->Isawampersand;
8830 PL_unsafe = proto_perl->Iunsafe;
8831 PL_inplace = SAVEPV(proto_perl->Iinplace);
8832 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8833 PL_perldb = proto_perl->Iperldb;
8834 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8836 /* magical thingies */
8837 /* XXX time(&PL_basetime) when asked for? */
8838 PL_basetime = proto_perl->Ibasetime;
8839 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8841 PL_maxsysfd = proto_perl->Imaxsysfd;
8842 PL_multiline = proto_perl->Imultiline;
8843 PL_statusvalue = proto_perl->Istatusvalue;
8845 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8848 /* shortcuts to various I/O objects */
8849 PL_stdingv = gv_dup(proto_perl->Istdingv);
8850 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8851 PL_defgv = gv_dup(proto_perl->Idefgv);
8852 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8853 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8854 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8856 /* shortcuts to regexp stuff */
8857 PL_replgv = gv_dup(proto_perl->Ireplgv);
8859 /* shortcuts to misc objects */
8860 PL_errgv = gv_dup(proto_perl->Ierrgv);
8862 /* shortcuts to debugging objects */
8863 PL_DBgv = gv_dup(proto_perl->IDBgv);
8864 PL_DBline = gv_dup(proto_perl->IDBline);
8865 PL_DBsub = gv_dup(proto_perl->IDBsub);
8866 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8867 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8868 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8869 PL_lineary = av_dup(proto_perl->Ilineary);
8870 PL_dbargs = av_dup(proto_perl->Idbargs);
8873 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8874 PL_curstash = hv_dup(proto_perl->Tcurstash);
8875 PL_debstash = hv_dup(proto_perl->Idebstash);
8876 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8877 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8879 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8880 PL_endav = av_dup_inc(proto_perl->Iendav);
8881 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8882 PL_initav = av_dup_inc(proto_perl->Iinitav);
8884 PL_sub_generation = proto_perl->Isub_generation;
8886 /* funky return mechanisms */
8887 PL_forkprocess = proto_perl->Iforkprocess;
8889 /* subprocess state */
8890 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8892 /* internal state */
8893 PL_tainting = proto_perl->Itainting;
8894 PL_maxo = proto_perl->Imaxo;
8895 if (proto_perl->Iop_mask)
8896 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8898 PL_op_mask = Nullch;
8900 /* current interpreter roots */
8901 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8902 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8903 PL_main_start = proto_perl->Imain_start;
8904 PL_eval_root = proto_perl->Ieval_root;
8905 PL_eval_start = proto_perl->Ieval_start;
8907 /* runtime control stuff */
8908 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8909 PL_copline = proto_perl->Icopline;
8911 PL_filemode = proto_perl->Ifilemode;
8912 PL_lastfd = proto_perl->Ilastfd;
8913 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8916 PL_gensym = proto_perl->Igensym;
8917 PL_preambled = proto_perl->Ipreambled;
8918 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8919 PL_laststatval = proto_perl->Ilaststatval;
8920 PL_laststype = proto_perl->Ilaststype;
8921 PL_mess_sv = Nullsv;
8923 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8924 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8926 /* interpreter atexit processing */
8927 PL_exitlistlen = proto_perl->Iexitlistlen;
8928 if (PL_exitlistlen) {
8929 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8930 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8933 PL_exitlist = (PerlExitListEntry*)NULL;
8934 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8936 PL_profiledata = NULL;
8937 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8938 /* PL_rsfp_filters entries have fake IoDIRP() */
8939 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8941 PL_compcv = cv_dup(proto_perl->Icompcv);
8942 PL_comppad = av_dup(proto_perl->Icomppad);
8943 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8944 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8945 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8946 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8947 proto_perl->Tcurpad);
8949 #ifdef HAVE_INTERP_INTERN
8950 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8953 /* more statics moved here */
8954 PL_generation = proto_perl->Igeneration;
8955 PL_DBcv = cv_dup(proto_perl->IDBcv);
8957 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8958 PL_in_clean_all = proto_perl->Iin_clean_all;
8960 PL_uid = proto_perl->Iuid;
8961 PL_euid = proto_perl->Ieuid;
8962 PL_gid = proto_perl->Igid;
8963 PL_egid = proto_perl->Iegid;
8964 PL_nomemok = proto_perl->Inomemok;
8965 PL_an = proto_perl->Ian;
8966 PL_cop_seqmax = proto_perl->Icop_seqmax;
8967 PL_op_seqmax = proto_perl->Iop_seqmax;
8968 PL_evalseq = proto_perl->Ievalseq;
8969 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8970 PL_origalen = proto_perl->Iorigalen;
8971 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8972 PL_osname = SAVEPV(proto_perl->Iosname);
8973 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8974 PL_sighandlerp = proto_perl->Isighandlerp;
8977 PL_runops = proto_perl->Irunops;
8979 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8982 PL_cshlen = proto_perl->Icshlen;
8983 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8986 PL_lex_state = proto_perl->Ilex_state;
8987 PL_lex_defer = proto_perl->Ilex_defer;
8988 PL_lex_expect = proto_perl->Ilex_expect;
8989 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8990 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8991 PL_lex_starts = proto_perl->Ilex_starts;
8992 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8993 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8994 PL_lex_op = proto_perl->Ilex_op;
8995 PL_lex_inpat = proto_perl->Ilex_inpat;
8996 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8997 PL_lex_brackets = proto_perl->Ilex_brackets;
8998 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8999 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9000 PL_lex_casemods = proto_perl->Ilex_casemods;
9001 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9002 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9004 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9005 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9006 PL_nexttoke = proto_perl->Inexttoke;
9008 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9009 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9010 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9011 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9012 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9013 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9014 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9015 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9016 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9017 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9018 PL_pending_ident = proto_perl->Ipending_ident;
9019 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9021 PL_expect = proto_perl->Iexpect;
9023 PL_multi_start = proto_perl->Imulti_start;
9024 PL_multi_end = proto_perl->Imulti_end;
9025 PL_multi_open = proto_perl->Imulti_open;
9026 PL_multi_close = proto_perl->Imulti_close;
9028 PL_error_count = proto_perl->Ierror_count;
9029 PL_subline = proto_perl->Isubline;
9030 PL_subname = sv_dup_inc(proto_perl->Isubname);
9032 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9033 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9034 PL_padix = proto_perl->Ipadix;
9035 PL_padix_floor = proto_perl->Ipadix_floor;
9036 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9038 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9039 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9040 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9041 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9042 PL_last_lop_op = proto_perl->Ilast_lop_op;
9043 PL_in_my = proto_perl->Iin_my;
9044 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9046 PL_cryptseen = proto_perl->Icryptseen;
9049 PL_hints = proto_perl->Ihints;
9051 PL_amagic_generation = proto_perl->Iamagic_generation;
9053 #ifdef USE_LOCALE_COLLATE
9054 PL_collation_ix = proto_perl->Icollation_ix;
9055 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9056 PL_collation_standard = proto_perl->Icollation_standard;
9057 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9058 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9059 #endif /* USE_LOCALE_COLLATE */
9061 #ifdef USE_LOCALE_NUMERIC
9062 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9063 PL_numeric_standard = proto_perl->Inumeric_standard;
9064 PL_numeric_local = proto_perl->Inumeric_local;
9065 PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix);
9066 #endif /* !USE_LOCALE_NUMERIC */
9068 /* utf8 character classes */
9069 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9070 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9071 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9072 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9073 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9074 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9075 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9076 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9077 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9078 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9079 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9080 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9081 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9082 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9083 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9084 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9085 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9088 PL_last_swash_hv = Nullhv; /* reinits on demand */
9089 PL_last_swash_klen = 0;
9090 PL_last_swash_key[0]= '\0';
9091 PL_last_swash_tmps = (U8*)NULL;
9092 PL_last_swash_slen = 0;
9094 /* perly.c globals */
9095 PL_yydebug = proto_perl->Iyydebug;
9096 PL_yynerrs = proto_perl->Iyynerrs;
9097 PL_yyerrflag = proto_perl->Iyyerrflag;
9098 PL_yychar = proto_perl->Iyychar;
9099 PL_yyval = proto_perl->Iyyval;
9100 PL_yylval = proto_perl->Iyylval;
9102 PL_glob_index = proto_perl->Iglob_index;
9103 PL_srand_called = proto_perl->Isrand_called;
9104 PL_uudmap['M'] = 0; /* reinits on demand */
9105 PL_bitcount = Nullch; /* reinits on demand */
9107 if (proto_perl->Ipsig_pend) {
9108 Newz(0, PL_psig_pend, SIG_SIZE, int);
9111 PL_psig_pend = (int*)NULL;
9114 if (proto_perl->Ipsig_ptr) {
9115 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9116 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9117 for (i = 1; i < SIG_SIZE; i++) {
9118 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9119 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9123 PL_psig_ptr = (SV**)NULL;
9124 PL_psig_name = (SV**)NULL;
9127 /* thrdvar.h stuff */
9129 if (flags & CLONEf_COPY_STACKS) {
9130 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9131 PL_tmps_ix = proto_perl->Ttmps_ix;
9132 PL_tmps_max = proto_perl->Ttmps_max;
9133 PL_tmps_floor = proto_perl->Ttmps_floor;
9134 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9136 while (i <= PL_tmps_ix) {
9137 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9141 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9142 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9143 Newz(54, PL_markstack, i, I32);
9144 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9145 - proto_perl->Tmarkstack);
9146 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9147 - proto_perl->Tmarkstack);
9148 Copy(proto_perl->Tmarkstack, PL_markstack,
9149 PL_markstack_ptr - PL_markstack + 1, I32);
9151 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9152 * NOTE: unlike the others! */
9153 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9154 PL_scopestack_max = proto_perl->Tscopestack_max;
9155 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9156 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9158 /* next push_return() sets PL_retstack[PL_retstack_ix]
9159 * NOTE: unlike the others! */
9160 PL_retstack_ix = proto_perl->Tretstack_ix;
9161 PL_retstack_max = proto_perl->Tretstack_max;
9162 Newz(54, PL_retstack, PL_retstack_max, OP*);
9163 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9165 /* NOTE: si_dup() looks at PL_markstack */
9166 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9168 /* PL_curstack = PL_curstackinfo->si_stack; */
9169 PL_curstack = av_dup(proto_perl->Tcurstack);
9170 PL_mainstack = av_dup(proto_perl->Tmainstack);
9172 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9173 PL_stack_base = AvARRAY(PL_curstack);
9174 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9175 - proto_perl->Tstack_base);
9176 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9178 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9179 * NOTE: unlike the others! */
9180 PL_savestack_ix = proto_perl->Tsavestack_ix;
9181 PL_savestack_max = proto_perl->Tsavestack_max;
9182 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9183 PL_savestack = ss_dup(proto_perl);
9187 ENTER; /* perl_destruct() wants to LEAVE; */
9190 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9191 PL_top_env = &PL_start_env;
9193 PL_op = proto_perl->Top;
9196 PL_Xpv = (XPV*)NULL;
9197 PL_na = proto_perl->Tna;
9199 PL_statbuf = proto_perl->Tstatbuf;
9200 PL_statcache = proto_perl->Tstatcache;
9201 PL_statgv = gv_dup(proto_perl->Tstatgv);
9202 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9204 PL_timesbuf = proto_perl->Ttimesbuf;
9207 PL_tainted = proto_perl->Ttainted;
9208 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9209 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9210 PL_rs = sv_dup_inc(proto_perl->Trs);
9211 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9212 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9213 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9214 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9215 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9216 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9217 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9219 PL_restartop = proto_perl->Trestartop;
9220 PL_in_eval = proto_perl->Tin_eval;
9221 PL_delaymagic = proto_perl->Tdelaymagic;
9222 PL_dirty = proto_perl->Tdirty;
9223 PL_localizing = proto_perl->Tlocalizing;
9225 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9226 PL_protect = proto_perl->Tprotect;
9228 PL_errors = sv_dup_inc(proto_perl->Terrors);
9229 PL_av_fetch_sv = Nullsv;
9230 PL_hv_fetch_sv = Nullsv;
9231 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9232 PL_modcount = proto_perl->Tmodcount;
9233 PL_lastgotoprobe = Nullop;
9234 PL_dumpindent = proto_perl->Tdumpindent;
9236 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9237 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9238 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9239 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9240 PL_sortcxix = proto_perl->Tsortcxix;
9241 PL_efloatbuf = Nullch; /* reinits on demand */
9242 PL_efloatsize = 0; /* reinits on demand */
9246 PL_screamfirst = NULL;
9247 PL_screamnext = NULL;
9248 PL_maxscream = -1; /* reinits on demand */
9249 PL_lastscream = Nullsv;
9251 PL_watchaddr = NULL;
9252 PL_watchok = Nullch;
9254 PL_regdummy = proto_perl->Tregdummy;
9255 PL_regcomp_parse = Nullch;
9256 PL_regxend = Nullch;
9257 PL_regcode = (regnode*)NULL;
9260 PL_regprecomp = Nullch;
9265 PL_seen_zerolen = 0;
9267 PL_regcomp_rx = (regexp*)NULL;
9269 PL_colorset = 0; /* reinits PL_colors[] */
9270 /*PL_colors[6] = {0,0,0,0,0,0};*/
9271 PL_reg_whilem_seen = 0;
9272 PL_reginput = Nullch;
9275 PL_regstartp = (I32*)NULL;
9276 PL_regendp = (I32*)NULL;
9277 PL_reglastparen = (U32*)NULL;
9278 PL_regtill = Nullch;
9280 PL_reg_start_tmp = (char**)NULL;
9281 PL_reg_start_tmpl = 0;
9282 PL_regdata = (struct reg_data*)NULL;
9285 PL_reg_eval_set = 0;
9287 PL_regprogram = (regnode*)NULL;
9289 PL_regcc = (CURCUR*)NULL;
9290 PL_reg_call_cc = (struct re_cc_state*)NULL;
9291 PL_reg_re = (regexp*)NULL;
9292 PL_reg_ganch = Nullch;
9294 PL_reg_magic = (MAGIC*)NULL;
9296 PL_reg_oldcurpm = (PMOP*)NULL;
9297 PL_reg_curpm = (PMOP*)NULL;
9298 PL_reg_oldsaved = Nullch;
9299 PL_reg_oldsavedlen = 0;
9301 PL_reg_leftiter = 0;
9302 PL_reg_poscache = Nullch;
9303 PL_reg_poscache_size= 0;
9305 /* RE engine - function pointers */
9306 PL_regcompp = proto_perl->Tregcompp;
9307 PL_regexecp = proto_perl->Tregexecp;
9308 PL_regint_start = proto_perl->Tregint_start;
9309 PL_regint_string = proto_perl->Tregint_string;
9310 PL_regfree = proto_perl->Tregfree;
9312 PL_reginterp_cnt = 0;
9313 PL_reg_starttry = 0;
9315 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9316 ptr_table_free(PL_ptr_table);
9317 PL_ptr_table = NULL;
9321 return (PerlInterpreter*)pPerl;
9327 #else /* !USE_ITHREADS */
9333 #endif /* USE_ITHREADS */
9336 do_report_used(pTHXo_ SV *sv)
9338 if (SvTYPE(sv) != SVTYPEMASK) {
9339 PerlIO_printf(Perl_debug_log, "****\n");
9345 do_clean_objs(pTHXo_ SV *sv)
9349 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9350 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9351 if (SvWEAKREF(sv)) {
9362 /* XXX Might want to check arrays, etc. */
9365 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9367 do_clean_named_objs(pTHXo_ SV *sv)
9369 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9370 if ( SvOBJECT(GvSV(sv)) ||
9371 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9372 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9373 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9374 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9376 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9384 do_clean_all(pTHXo_ SV *sv)
9386 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9387 SvFLAGS(sv) |= SVf_BREAK;