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); \
66 if (PL_debug & 32768) \
76 if (PL_debug & 32768) {
81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
83 svend = &sva[SvREFCNT(sva)];
84 if (p >= sv && p < svend)
88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
90 "Attempt to free non-arena SV: 0x%"UVxf,
98 #else /* ! DEBUGGING */
100 #define del_SV(p) plant_SV(p)
102 #endif /* DEBUGGING */
105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
110 Zero(ptr, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
197 XPV *arena, *arenanext;
199 /* Free arenas here, but be careful about fake ones. (We assume
200 contiguity of the fake ones with the corresponding real ones.) */
202 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
203 svanext = (SV*) SvANY(sva);
204 while (svanext && SvFAKE(svanext))
205 svanext = (SV*) SvANY(svanext);
208 Safefree((void *)sva);
211 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
212 arenanext = (XPV*)arena->xpv_pv;
215 PL_xiv_arenaroot = 0;
217 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
218 arenanext = (XPV*)arena->xpv_pv;
221 PL_xnv_arenaroot = 0;
223 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
224 arenanext = (XPV*)arena->xpv_pv;
227 PL_xrv_arenaroot = 0;
229 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
230 arenanext = (XPV*)arena->xpv_pv;
233 PL_xpv_arenaroot = 0;
235 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
236 arenanext = (XPV*)arena->xpv_pv;
239 PL_xpviv_arenaroot = 0;
241 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
242 arenanext = (XPV*)arena->xpv_pv;
245 PL_xpvnv_arenaroot = 0;
247 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
248 arenanext = (XPV*)arena->xpv_pv;
251 PL_xpvcv_arenaroot = 0;
253 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
254 arenanext = (XPV*)arena->xpv_pv;
257 PL_xpvav_arenaroot = 0;
259 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
260 arenanext = (XPV*)arena->xpv_pv;
263 PL_xpvhv_arenaroot = 0;
265 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
266 arenanext = (XPV*)arena->xpv_pv;
269 PL_xpvmg_arenaroot = 0;
271 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
272 arenanext = (XPV*)arena->xpv_pv;
275 PL_xpvlv_arenaroot = 0;
277 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
278 arenanext = (XPV*)arena->xpv_pv;
281 PL_xpvbm_arenaroot = 0;
283 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
284 arenanext = (XPV*)arena->xpv_pv;
290 Safefree(PL_nice_chunk);
291 PL_nice_chunk = Nullch;
292 PL_nice_chunk_size = 0;
298 Perl_report_uninit(pTHX)
301 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
302 " in ", PL_op_desc[PL_op->op_type]);
304 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
316 * See comment in more_xiv() -- RAM.
318 PL_xiv_root = *(IV**)xiv;
320 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
324 S_del_xiv(pTHX_ XPVIV *p)
326 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
328 *(IV**)xiv = PL_xiv_root;
339 New(705, ptr, 1008/sizeof(XPV), XPV);
340 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
341 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
344 xivend = &xiv[1008 / sizeof(IV) - 1];
345 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
347 while (xiv < xivend) {
348 *(IV**)xiv = (IV *)(xiv + 1);
362 PL_xnv_root = *(NV**)xnv;
364 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
368 S_del_xnv(pTHX_ XPVNV *p)
370 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
372 *(NV**)xnv = PL_xnv_root;
383 New(711, ptr, 1008/sizeof(XPV), XPV);
384 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
385 PL_xnv_arenaroot = ptr;
388 xnvend = &xnv[1008 / sizeof(NV) - 1];
389 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
391 while (xnv < xnvend) {
392 *(NV**)xnv = (NV*)(xnv + 1);
406 PL_xrv_root = (XRV*)xrv->xrv_rv;
412 S_del_xrv(pTHX_ XRV *p)
415 p->xrv_rv = (SV*)PL_xrv_root;
424 register XRV* xrvend;
426 New(712, ptr, 1008/sizeof(XPV), XPV);
427 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
428 PL_xrv_arenaroot = ptr;
431 xrvend = &xrv[1008 / sizeof(XRV) - 1];
432 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
434 while (xrv < xrvend) {
435 xrv->xrv_rv = (SV*)(xrv + 1);
449 PL_xpv_root = (XPV*)xpv->xpv_pv;
455 S_del_xpv(pTHX_ XPV *p)
458 p->xpv_pv = (char*)PL_xpv_root;
467 register XPV* xpvend;
468 New(713, xpv, 1008/sizeof(XPV), XPV);
469 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
470 PL_xpv_arenaroot = xpv;
472 xpvend = &xpv[1008 / sizeof(XPV) - 1];
474 while (xpv < xpvend) {
475 xpv->xpv_pv = (char*)(xpv + 1);
488 xpviv = PL_xpviv_root;
489 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
495 S_del_xpviv(pTHX_ XPVIV *p)
498 p->xpv_pv = (char*)PL_xpviv_root;
506 register XPVIV* xpviv;
507 register XPVIV* xpvivend;
508 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
509 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
510 PL_xpviv_arenaroot = xpviv;
512 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
513 PL_xpviv_root = ++xpviv;
514 while (xpviv < xpvivend) {
515 xpviv->xpv_pv = (char*)(xpviv + 1);
528 xpvnv = PL_xpvnv_root;
529 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
535 S_del_xpvnv(pTHX_ XPVNV *p)
538 p->xpv_pv = (char*)PL_xpvnv_root;
546 register XPVNV* xpvnv;
547 register XPVNV* xpvnvend;
548 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
549 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
550 PL_xpvnv_arenaroot = xpvnv;
552 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
553 PL_xpvnv_root = ++xpvnv;
554 while (xpvnv < xpvnvend) {
555 xpvnv->xpv_pv = (char*)(xpvnv + 1);
568 xpvcv = PL_xpvcv_root;
569 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
575 S_del_xpvcv(pTHX_ XPVCV *p)
578 p->xpv_pv = (char*)PL_xpvcv_root;
586 register XPVCV* xpvcv;
587 register XPVCV* xpvcvend;
588 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
589 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
590 PL_xpvcv_arenaroot = xpvcv;
592 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
593 PL_xpvcv_root = ++xpvcv;
594 while (xpvcv < xpvcvend) {
595 xpvcv->xpv_pv = (char*)(xpvcv + 1);
608 xpvav = PL_xpvav_root;
609 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
615 S_del_xpvav(pTHX_ XPVAV *p)
618 p->xav_array = (char*)PL_xpvav_root;
626 register XPVAV* xpvav;
627 register XPVAV* xpvavend;
628 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
629 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
630 PL_xpvav_arenaroot = xpvav;
632 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
633 PL_xpvav_root = ++xpvav;
634 while (xpvav < xpvavend) {
635 xpvav->xav_array = (char*)(xpvav + 1);
638 xpvav->xav_array = 0;
648 xpvhv = PL_xpvhv_root;
649 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
655 S_del_xpvhv(pTHX_ XPVHV *p)
658 p->xhv_array = (char*)PL_xpvhv_root;
666 register XPVHV* xpvhv;
667 register XPVHV* xpvhvend;
668 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
669 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
670 PL_xpvhv_arenaroot = xpvhv;
672 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
673 PL_xpvhv_root = ++xpvhv;
674 while (xpvhv < xpvhvend) {
675 xpvhv->xhv_array = (char*)(xpvhv + 1);
678 xpvhv->xhv_array = 0;
688 xpvmg = PL_xpvmg_root;
689 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
695 S_del_xpvmg(pTHX_ XPVMG *p)
698 p->xpv_pv = (char*)PL_xpvmg_root;
706 register XPVMG* xpvmg;
707 register XPVMG* xpvmgend;
708 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
709 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
710 PL_xpvmg_arenaroot = xpvmg;
712 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
713 PL_xpvmg_root = ++xpvmg;
714 while (xpvmg < xpvmgend) {
715 xpvmg->xpv_pv = (char*)(xpvmg + 1);
728 xpvlv = PL_xpvlv_root;
729 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
735 S_del_xpvlv(pTHX_ XPVLV *p)
738 p->xpv_pv = (char*)PL_xpvlv_root;
746 register XPVLV* xpvlv;
747 register XPVLV* xpvlvend;
748 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
749 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
750 PL_xpvlv_arenaroot = xpvlv;
752 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
753 PL_xpvlv_root = ++xpvlv;
754 while (xpvlv < xpvlvend) {
755 xpvlv->xpv_pv = (char*)(xpvlv + 1);
768 xpvbm = PL_xpvbm_root;
769 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
775 S_del_xpvbm(pTHX_ XPVBM *p)
778 p->xpv_pv = (char*)PL_xpvbm_root;
786 register XPVBM* xpvbm;
787 register XPVBM* xpvbmend;
788 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
789 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
790 PL_xpvbm_arenaroot = xpvbm;
792 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
793 PL_xpvbm_root = ++xpvbm;
794 while (xpvbm < xpvbmend) {
795 xpvbm->xpv_pv = (char*)(xpvbm + 1);
802 # define my_safemalloc(s) (void*)safexmalloc(717,s)
803 # define my_safefree(p) safexfree((char*)p)
805 # define my_safemalloc(s) (void*)safemalloc(s)
806 # define my_safefree(p) safefree((char*)p)
811 #define new_XIV() my_safemalloc(sizeof(XPVIV))
812 #define del_XIV(p) my_safefree(p)
814 #define new_XNV() my_safemalloc(sizeof(XPVNV))
815 #define del_XNV(p) my_safefree(p)
817 #define new_XRV() my_safemalloc(sizeof(XRV))
818 #define del_XRV(p) my_safefree(p)
820 #define new_XPV() my_safemalloc(sizeof(XPV))
821 #define del_XPV(p) my_safefree(p)
823 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
824 #define del_XPVIV(p) my_safefree(p)
826 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
827 #define del_XPVNV(p) my_safefree(p)
829 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
830 #define del_XPVCV(p) my_safefree(p)
832 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
833 #define del_XPVAV(p) my_safefree(p)
835 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
836 #define del_XPVHV(p) my_safefree(p)
838 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
839 #define del_XPVMG(p) my_safefree(p)
841 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
842 #define del_XPVLV(p) my_safefree(p)
844 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
845 #define del_XPVBM(p) my_safefree(p)
849 #define new_XIV() (void*)new_xiv()
850 #define del_XIV(p) del_xiv((XPVIV*) p)
852 #define new_XNV() (void*)new_xnv()
853 #define del_XNV(p) del_xnv((XPVNV*) p)
855 #define new_XRV() (void*)new_xrv()
856 #define del_XRV(p) del_xrv((XRV*) p)
858 #define new_XPV() (void*)new_xpv()
859 #define del_XPV(p) del_xpv((XPV *)p)
861 #define new_XPVIV() (void*)new_xpviv()
862 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
864 #define new_XPVNV() (void*)new_xpvnv()
865 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
867 #define new_XPVCV() (void*)new_xpvcv()
868 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
870 #define new_XPVAV() (void*)new_xpvav()
871 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
873 #define new_XPVHV() (void*)new_xpvhv()
874 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
876 #define new_XPVMG() (void*)new_xpvmg()
877 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
879 #define new_XPVLV() (void*)new_xpvlv()
880 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
882 #define new_XPVBM() (void*)new_xpvbm()
883 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
887 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
888 #define del_XPVGV(p) my_safefree(p)
890 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
891 #define del_XPVFM(p) my_safefree(p)
893 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
894 #define del_XPVIO(p) my_safefree(p)
897 =for apidoc sv_upgrade
899 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
906 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
916 if (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 return sv_2pv(sv,lp);
2891 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2894 return sv_2pvutf8(sv, &n_a);
2898 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2900 sv_utf8_upgrade(sv);
2901 return SvPV(sv,*lp);
2904 /* This function is only called on magical items */
2906 Perl_sv_2bool(pTHX_ register SV *sv)
2915 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2916 (SvRV(tmpsv) != SvRV(sv)))
2917 return SvTRUE(tmpsv);
2918 return SvRV(sv) != 0;
2921 register XPV* Xpvtmp;
2922 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2923 (*Xpvtmp->xpv_pv > '0' ||
2924 Xpvtmp->xpv_cur > 1 ||
2925 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2932 return SvIVX(sv) != 0;
2935 return SvNVX(sv) != 0.0;
2943 =for apidoc sv_utf8_upgrade
2945 Convert the PV of an SV to its UTF8-encoded form.
2951 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2956 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2959 /* This function could be much more efficient if we had a FLAG in SVs
2960 * to signal if there are any hibit chars in the PV.
2961 * Given that there isn't make loop fast as possible
2967 if ((hibit = UTF8_IS_CONTINUED(*t++)))
2974 if (SvREADONLY(sv) && SvFAKE(sv)) {
2975 sv_force_normal(sv);
2978 len = SvCUR(sv) + 1; /* Plus the \0 */
2979 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2980 SvCUR(sv) = len - 1;
2982 Safefree(s); /* No longer using what was there before. */
2983 SvLEN(sv) = len; /* No longer know the real size. */
2989 =for apidoc sv_utf8_downgrade
2991 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2992 This may not be possible if the PV contains non-byte encoding characters;
2993 if this is the case, either returns false or, if C<fail_ok> is not
3000 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3002 if (SvPOK(sv) && SvUTF8(sv)) {
3007 if (SvREADONLY(sv) && SvFAKE(sv))
3008 sv_force_normal(sv);
3010 if (!utf8_to_bytes((U8*)s, &len)) {
3015 Perl_croak(aTHX_ "Wide character in %s",
3016 PL_op_desc[PL_op->op_type]);
3018 Perl_croak(aTHX_ "Wide character");
3030 =for apidoc sv_utf8_encode
3032 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3033 flag so that it looks like bytes again. Nothing calls this.
3039 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3041 sv_utf8_upgrade(sv);
3046 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3052 if (!sv_utf8_downgrade(sv, TRUE))
3055 /* it is actually just a matter of turning the utf8 flag on, but
3056 * we want to make sure everything inside is valid utf8 first.
3059 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
3063 if (UTF8_IS_CONTINUED(*c++)) {
3073 /* Note: sv_setsv() should not be called with a source string that needs
3074 * to be reused, since it may destroy the source string if it is marked
3079 =for apidoc sv_setsv
3081 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3082 The source SV may be destroyed if it is mortal. Does not handle 'set'
3083 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3090 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3092 register U32 sflags;
3098 SV_CHECK_THINKFIRST(dstr);
3100 sstr = &PL_sv_undef;
3101 stype = SvTYPE(sstr);
3102 dtype = SvTYPE(dstr);
3106 /* There's a lot of redundancy below but we're going for speed here */
3111 if (dtype != SVt_PVGV) {
3112 (void)SvOK_off(dstr);
3120 sv_upgrade(dstr, SVt_IV);
3123 sv_upgrade(dstr, SVt_PVNV);
3127 sv_upgrade(dstr, SVt_PVIV);
3130 (void)SvIOK_only(dstr);
3131 SvIVX(dstr) = SvIVX(sstr);
3134 if (SvTAINTED(sstr))
3145 sv_upgrade(dstr, SVt_NV);
3150 sv_upgrade(dstr, SVt_PVNV);
3153 SvNVX(dstr) = SvNVX(sstr);
3154 (void)SvNOK_only(dstr);
3155 if (SvTAINTED(sstr))
3163 sv_upgrade(dstr, SVt_RV);
3164 else if (dtype == SVt_PVGV &&
3165 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3168 if (GvIMPORTED(dstr) != GVf_IMPORTED
3169 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3171 GvIMPORTED_on(dstr);
3182 sv_upgrade(dstr, SVt_PV);
3185 if (dtype < SVt_PVIV)
3186 sv_upgrade(dstr, SVt_PVIV);
3189 if (dtype < SVt_PVNV)
3190 sv_upgrade(dstr, SVt_PVNV);
3197 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3198 PL_op_name[PL_op->op_type]);
3200 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3204 if (dtype <= SVt_PVGV) {
3206 if (dtype != SVt_PVGV) {
3207 char *name = GvNAME(sstr);
3208 STRLEN len = GvNAMELEN(sstr);
3209 sv_upgrade(dstr, SVt_PVGV);
3210 sv_magic(dstr, dstr, '*', Nullch, 0);
3211 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3212 GvNAME(dstr) = savepvn(name, len);
3213 GvNAMELEN(dstr) = len;
3214 SvFAKE_on(dstr); /* can coerce to non-glob */
3216 /* ahem, death to those who redefine active sort subs */
3217 else if (PL_curstackinfo->si_type == PERLSI_SORT
3218 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3219 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3222 #ifdef GV_SHARED_CHECK
3223 if (GvSHARED((GV*)dstr)) {
3224 Perl_croak(aTHX_ PL_no_modify);
3228 (void)SvOK_off(dstr);
3229 GvINTRO_off(dstr); /* one-shot flag */
3231 GvGP(dstr) = gp_ref(GvGP(sstr));
3232 if (SvTAINTED(sstr))
3234 if (GvIMPORTED(dstr) != GVf_IMPORTED
3235 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3237 GvIMPORTED_on(dstr);
3245 if (SvGMAGICAL(sstr)) {
3247 if (SvTYPE(sstr) != stype) {
3248 stype = SvTYPE(sstr);
3249 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3253 if (stype == SVt_PVLV)
3254 (void)SvUPGRADE(dstr, SVt_PVNV);
3256 (void)SvUPGRADE(dstr, stype);
3259 sflags = SvFLAGS(sstr);
3261 if (sflags & SVf_ROK) {
3262 if (dtype >= SVt_PV) {
3263 if (dtype == SVt_PVGV) {
3264 SV *sref = SvREFCNT_inc(SvRV(sstr));
3266 int intro = GvINTRO(dstr);
3268 #ifdef GV_SHARED_CHECK
3269 if (GvSHARED((GV*)dstr)) {
3270 Perl_croak(aTHX_ PL_no_modify);
3277 GvINTRO_off(dstr); /* one-shot flag */
3278 Newz(602,gp, 1, GP);
3279 GvGP(dstr) = gp_ref(gp);
3280 GvSV(dstr) = NEWSV(72,0);
3281 GvLINE(dstr) = CopLINE(PL_curcop);
3282 GvEGV(dstr) = (GV*)dstr;
3285 switch (SvTYPE(sref)) {
3288 SAVESPTR(GvAV(dstr));
3290 dref = (SV*)GvAV(dstr);
3291 GvAV(dstr) = (AV*)sref;
3292 if (!GvIMPORTED_AV(dstr)
3293 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3295 GvIMPORTED_AV_on(dstr);
3300 SAVESPTR(GvHV(dstr));
3302 dref = (SV*)GvHV(dstr);
3303 GvHV(dstr) = (HV*)sref;
3304 if (!GvIMPORTED_HV(dstr)
3305 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3307 GvIMPORTED_HV_on(dstr);
3312 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3313 SvREFCNT_dec(GvCV(dstr));
3314 GvCV(dstr) = Nullcv;
3315 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3316 PL_sub_generation++;
3318 SAVESPTR(GvCV(dstr));
3321 dref = (SV*)GvCV(dstr);
3322 if (GvCV(dstr) != (CV*)sref) {
3323 CV* cv = GvCV(dstr);
3325 if (!GvCVGEN((GV*)dstr) &&
3326 (CvROOT(cv) || CvXSUB(cv)))
3328 /* ahem, death to those who redefine
3329 * active sort subs */
3330 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3331 PL_sortcop == CvSTART(cv))
3333 "Can't redefine active sort subroutine %s",
3334 GvENAME((GV*)dstr));
3335 /* Redefining a sub - warning is mandatory if
3336 it was a const and its value changed. */
3337 if (ckWARN(WARN_REDEFINE)
3339 && (!CvCONST((CV*)sref)
3340 || sv_cmp(cv_const_sv(cv),
3341 cv_const_sv((CV*)sref)))))
3343 Perl_warner(aTHX_ WARN_REDEFINE,
3345 ? "Constant subroutine %s redefined"
3346 : "Subroutine %s redefined",
3347 GvENAME((GV*)dstr));
3350 cv_ckproto(cv, (GV*)dstr,
3351 SvPOK(sref) ? SvPVX(sref) : Nullch);
3353 GvCV(dstr) = (CV*)sref;
3354 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3355 GvASSUMECV_on(dstr);
3356 PL_sub_generation++;
3358 if (!GvIMPORTED_CV(dstr)
3359 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3361 GvIMPORTED_CV_on(dstr);
3366 SAVESPTR(GvIOp(dstr));
3368 dref = (SV*)GvIOp(dstr);
3369 GvIOp(dstr) = (IO*)sref;
3373 SAVESPTR(GvFORM(dstr));
3375 dref = (SV*)GvFORM(dstr);
3376 GvFORM(dstr) = (CV*)sref;
3380 SAVESPTR(GvSV(dstr));
3382 dref = (SV*)GvSV(dstr);
3384 if (!GvIMPORTED_SV(dstr)
3385 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3387 GvIMPORTED_SV_on(dstr);
3395 if (SvTAINTED(sstr))
3400 (void)SvOOK_off(dstr); /* backoff */
3402 Safefree(SvPVX(dstr));
3403 SvLEN(dstr)=SvCUR(dstr)=0;
3406 (void)SvOK_off(dstr);
3407 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3409 if (sflags & SVp_NOK) {
3411 /* Only set the public OK flag if the source has public OK. */
3412 if (sflags & SVf_NOK)
3413 SvFLAGS(dstr) |= SVf_NOK;
3414 SvNVX(dstr) = SvNVX(sstr);
3416 if (sflags & SVp_IOK) {
3417 (void)SvIOKp_on(dstr);
3418 if (sflags & SVf_IOK)
3419 SvFLAGS(dstr) |= SVf_IOK;
3420 if (sflags & SVf_IVisUV)
3422 SvIVX(dstr) = SvIVX(sstr);
3424 if (SvAMAGIC(sstr)) {
3428 else if (sflags & SVp_POK) {
3431 * Check to see if we can just swipe the string. If so, it's a
3432 * possible small lose on short strings, but a big win on long ones.
3433 * It might even be a win on short strings if SvPVX(dstr)
3434 * has to be allocated and SvPVX(sstr) has to be freed.
3437 if (SvTEMP(sstr) && /* slated for free anyway? */
3438 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3439 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3440 SvLEN(sstr) && /* and really is a string */
3441 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3443 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3445 SvFLAGS(dstr) &= ~SVf_OOK;
3446 Safefree(SvPVX(dstr) - SvIVX(dstr));
3448 else if (SvLEN(dstr))
3449 Safefree(SvPVX(dstr));
3451 (void)SvPOK_only(dstr);
3452 SvPV_set(dstr, SvPVX(sstr));
3453 SvLEN_set(dstr, SvLEN(sstr));
3454 SvCUR_set(dstr, SvCUR(sstr));
3457 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3458 SvPV_set(sstr, Nullch);
3463 else { /* have to copy actual string */
3464 STRLEN len = SvCUR(sstr);
3466 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3467 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3468 SvCUR_set(dstr, len);
3469 *SvEND(dstr) = '\0';
3470 (void)SvPOK_only(dstr);
3472 if (sflags & SVf_UTF8)
3475 if (sflags & SVp_NOK) {
3477 if (sflags & SVf_NOK)
3478 SvFLAGS(dstr) |= SVf_NOK;
3479 SvNVX(dstr) = SvNVX(sstr);
3481 if (sflags & SVp_IOK) {
3482 (void)SvIOKp_on(dstr);
3483 if (sflags & SVf_IOK)
3484 SvFLAGS(dstr) |= SVf_IOK;
3485 if (sflags & SVf_IVisUV)
3487 SvIVX(dstr) = SvIVX(sstr);
3490 else if (sflags & SVp_IOK) {
3491 if (sflags & SVf_IOK)
3492 (void)SvIOK_only(dstr);
3494 (void)SvOK_off(dstr);
3495 (void)SvIOKp_on(dstr);
3497 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3498 if (sflags & SVf_IVisUV)
3500 SvIVX(dstr) = SvIVX(sstr);
3501 if (sflags & SVp_NOK) {
3502 if (sflags & SVf_NOK)
3503 (void)SvNOK_on(dstr);
3505 (void)SvNOKp_on(dstr);
3506 SvNVX(dstr) = SvNVX(sstr);
3509 else if (sflags & SVp_NOK) {
3510 if (sflags & SVf_NOK)
3511 (void)SvNOK_only(dstr);
3513 (void)SvOK_off(dstr);
3516 SvNVX(dstr) = SvNVX(sstr);
3519 if (dtype == SVt_PVGV) {
3520 if (ckWARN(WARN_MISC))
3521 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3524 (void)SvOK_off(dstr);
3526 if (SvTAINTED(sstr))
3531 =for apidoc sv_setsv_mg
3533 Like C<sv_setsv>, but also handles 'set' magic.
3539 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3541 sv_setsv(dstr,sstr);
3546 =for apidoc sv_setpvn
3548 Copies a string into an SV. The C<len> parameter indicates the number of
3549 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3555 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3557 register char *dptr;
3559 SV_CHECK_THINKFIRST(sv);
3565 /* len is STRLEN which is unsigned, need to copy to signed */
3569 (void)SvUPGRADE(sv, SVt_PV);
3571 SvGROW(sv, len + 1);
3573 Move(ptr,dptr,len,char);
3576 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3581 =for apidoc sv_setpvn_mg
3583 Like C<sv_setpvn>, but also handles 'set' magic.
3589 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3591 sv_setpvn(sv,ptr,len);
3596 =for apidoc sv_setpv
3598 Copies a string into an SV. The string must be null-terminated. Does not
3599 handle 'set' magic. See C<sv_setpv_mg>.
3605 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3607 register STRLEN len;
3609 SV_CHECK_THINKFIRST(sv);
3615 (void)SvUPGRADE(sv, SVt_PV);
3617 SvGROW(sv, len + 1);
3618 Move(ptr,SvPVX(sv),len+1,char);
3620 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3625 =for apidoc sv_setpv_mg
3627 Like C<sv_setpv>, but also handles 'set' magic.
3633 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3640 =for apidoc sv_usepvn
3642 Tells an SV to use C<ptr> to find its string value. Normally the string is
3643 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3644 The C<ptr> should point to memory that was allocated by C<malloc>. The
3645 string length, C<len>, must be supplied. This function will realloc the
3646 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3647 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3648 See C<sv_usepvn_mg>.
3654 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3656 SV_CHECK_THINKFIRST(sv);
3657 (void)SvUPGRADE(sv, SVt_PV);
3662 (void)SvOOK_off(sv);
3663 if (SvPVX(sv) && SvLEN(sv))
3664 Safefree(SvPVX(sv));
3665 Renew(ptr, len+1, char);
3668 SvLEN_set(sv, len+1);
3670 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3675 =for apidoc sv_usepvn_mg
3677 Like C<sv_usepvn>, but also handles 'set' magic.
3683 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3685 sv_usepvn(sv,ptr,len);
3690 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3692 if (SvREADONLY(sv)) {
3694 char *pvx = SvPVX(sv);
3695 STRLEN len = SvCUR(sv);
3696 U32 hash = SvUVX(sv);
3697 SvGROW(sv, len + 1);
3698 Move(pvx,SvPVX(sv),len,char);
3702 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3704 else if (PL_curcop != &PL_compiling)
3705 Perl_croak(aTHX_ PL_no_modify);
3708 sv_unref_flags(sv, flags);
3709 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3714 Perl_sv_force_normal(pTHX_ register SV *sv)
3716 sv_force_normal_flags(sv, 0);
3722 Efficient removal of characters from the beginning of the string buffer.
3723 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3724 the string buffer. The C<ptr> becomes the first character of the adjusted
3731 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3735 register STRLEN delta;
3737 if (!ptr || !SvPOKp(sv))
3739 SV_CHECK_THINKFIRST(sv);
3740 if (SvTYPE(sv) < SVt_PVIV)
3741 sv_upgrade(sv,SVt_PVIV);
3744 if (!SvLEN(sv)) { /* make copy of shared string */
3745 char *pvx = SvPVX(sv);
3746 STRLEN len = SvCUR(sv);
3747 SvGROW(sv, len + 1);
3748 Move(pvx,SvPVX(sv),len,char);
3752 SvFLAGS(sv) |= SVf_OOK;
3754 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3755 delta = ptr - SvPVX(sv);
3763 =for apidoc sv_catpvn
3765 Concatenates the string onto the end of the string which is in the SV. The
3766 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3767 'set' magic. See C<sv_catpvn_mg>.
3773 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3778 junk = SvPV_force(sv, tlen);
3779 SvGROW(sv, tlen + len + 1);
3782 Move(ptr,SvPVX(sv)+tlen,len,char);
3785 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3790 =for apidoc sv_catpvn_mg
3792 Like C<sv_catpvn>, but also handles 'set' magic.
3798 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3800 sv_catpvn(sv,ptr,len);
3805 =for apidoc sv_catsv
3807 Concatenates the string from SV C<ssv> onto the end of the string in
3808 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3809 not 'set' magic. See C<sv_catsv_mg>.
3814 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3820 if ((spv = SvPV(ssv, slen))) {
3821 bool dutf8 = DO_UTF8(dsv);
3822 bool sutf8 = DO_UTF8(ssv);
3825 sv_catpvn(dsv,spv,slen);
3828 /* Not modifying source SV, so taking a temporary copy. */
3829 SV* csv = sv_2mortal(newSVsv(ssv));
3833 sv_utf8_upgrade(csv);
3834 cpv = SvPV(csv,clen);
3835 sv_catpvn(dsv,cpv,clen);
3838 sv_utf8_upgrade(dsv);
3839 sv_catpvn(dsv,spv,slen);
3840 SvUTF8_on(dsv); /* If dsv has no wide characters. */
3847 =for apidoc sv_catsv_mg
3849 Like C<sv_catsv>, but also handles 'set' magic.
3855 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3862 =for apidoc sv_catpv
3864 Concatenates the string onto the end of the string which is in the SV.
3865 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3871 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3873 register STRLEN len;
3879 junk = SvPV_force(sv, tlen);
3881 SvGROW(sv, tlen + len + 1);
3884 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3886 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3891 =for apidoc sv_catpv_mg
3893 Like C<sv_catpv>, but also handles 'set' magic.
3899 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3906 Perl_newSV(pTHX_ STRLEN len)
3912 sv_upgrade(sv, SVt_PV);
3913 SvGROW(sv, len + 1);
3918 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3921 =for apidoc sv_magic
3923 Adds magic to an SV.
3929 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3933 if (SvREADONLY(sv)) {
3934 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3935 Perl_croak(aTHX_ PL_no_modify);
3937 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3938 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3945 (void)SvUPGRADE(sv, SVt_PVMG);
3947 Newz(702,mg, 1, MAGIC);
3948 mg->mg_moremagic = SvMAGIC(sv);
3951 /* Some magic sontains a reference loop, where the sv and object refer to
3952 each other. To prevent a avoid a reference loop that would prevent such
3953 objects being freed, we look for such loops and if we find one we avoid
3954 incrementing the object refcount. */
3955 if (!obj || obj == sv || how == '#' || how == 'r' ||
3956 (SvTYPE(obj) == SVt_PVGV &&
3957 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
3958 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
3959 GvFORM(obj) == (CV*)sv)))
3964 mg->mg_obj = SvREFCNT_inc(obj);
3965 mg->mg_flags |= MGf_REFCOUNTED;
3968 mg->mg_len = namlen;
3971 mg->mg_ptr = savepvn(name, namlen);
3972 else if (namlen == HEf_SVKEY)
3973 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3978 mg->mg_virtual = &PL_vtbl_sv;
3981 mg->mg_virtual = &PL_vtbl_amagic;
3984 mg->mg_virtual = &PL_vtbl_amagicelem;
3987 mg->mg_virtual = &PL_vtbl_ovrld;
3990 mg->mg_virtual = &PL_vtbl_bm;
3993 mg->mg_virtual = &PL_vtbl_regdata;
3996 mg->mg_virtual = &PL_vtbl_regdatum;
3999 mg->mg_virtual = &PL_vtbl_env;
4002 mg->mg_virtual = &PL_vtbl_fm;
4005 mg->mg_virtual = &PL_vtbl_envelem;
4008 mg->mg_virtual = &PL_vtbl_mglob;
4011 mg->mg_virtual = &PL_vtbl_isa;
4014 mg->mg_virtual = &PL_vtbl_isaelem;
4017 mg->mg_virtual = &PL_vtbl_nkeys;
4024 mg->mg_virtual = &PL_vtbl_dbline;
4028 mg->mg_virtual = &PL_vtbl_mutex;
4030 #endif /* USE_THREADS */
4031 #ifdef USE_LOCALE_COLLATE
4033 mg->mg_virtual = &PL_vtbl_collxfrm;
4035 #endif /* USE_LOCALE_COLLATE */
4037 mg->mg_virtual = &PL_vtbl_pack;
4041 mg->mg_virtual = &PL_vtbl_packelem;
4044 mg->mg_virtual = &PL_vtbl_regexp;
4047 mg->mg_virtual = &PL_vtbl_sig;
4050 mg->mg_virtual = &PL_vtbl_sigelem;
4053 mg->mg_virtual = &PL_vtbl_taint;
4057 mg->mg_virtual = &PL_vtbl_uvar;
4060 mg->mg_virtual = &PL_vtbl_vec;
4063 mg->mg_virtual = &PL_vtbl_substr;
4066 mg->mg_virtual = &PL_vtbl_defelem;
4069 mg->mg_virtual = &PL_vtbl_glob;
4072 mg->mg_virtual = &PL_vtbl_arylen;
4075 mg->mg_virtual = &PL_vtbl_pos;
4078 mg->mg_virtual = &PL_vtbl_backref;
4080 case '~': /* Reserved for use by extensions not perl internals. */
4081 /* Useful for attaching extension internal data to perl vars. */
4082 /* Note that multiple extensions may clash if magical scalars */
4083 /* etc holding private data from one are passed to another. */
4087 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4091 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4095 =for apidoc sv_unmagic
4097 Removes magic from an SV.
4103 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4107 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4110 for (mg = *mgp; mg; mg = *mgp) {
4111 if (mg->mg_type == type) {
4112 MGVTBL* vtbl = mg->mg_virtual;
4113 *mgp = mg->mg_moremagic;
4114 if (vtbl && vtbl->svt_free)
4115 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4116 if (mg->mg_ptr && mg->mg_type != 'g') {
4117 if (mg->mg_len >= 0)
4118 Safefree(mg->mg_ptr);
4119 else if (mg->mg_len == HEf_SVKEY)
4120 SvREFCNT_dec((SV*)mg->mg_ptr);
4122 if (mg->mg_flags & MGf_REFCOUNTED)
4123 SvREFCNT_dec(mg->mg_obj);
4127 mgp = &mg->mg_moremagic;
4131 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4138 =for apidoc sv_rvweaken
4146 Perl_sv_rvweaken(pTHX_ SV *sv)
4149 if (!SvOK(sv)) /* let undefs pass */
4152 Perl_croak(aTHX_ "Can't weaken a nonreference");
4153 else if (SvWEAKREF(sv)) {
4154 if (ckWARN(WARN_MISC))
4155 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4159 sv_add_backref(tsv, sv);
4166 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4170 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4171 av = (AV*)mg->mg_obj;
4174 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4175 SvREFCNT_dec(av); /* for sv_magic */
4181 S_sv_del_backref(pTHX_ SV *sv)
4188 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4189 Perl_croak(aTHX_ "panic: del_backref");
4190 av = (AV *)mg->mg_obj;
4195 svp[i] = &PL_sv_undef; /* XXX */
4202 =for apidoc sv_insert
4204 Inserts a string at the specified offset/length within the SV. Similar to
4205 the Perl substr() function.
4211 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4215 register char *midend;
4216 register char *bigend;
4222 Perl_croak(aTHX_ "Can't modify non-existent substring");
4223 SvPV_force(bigstr, curlen);
4224 (void)SvPOK_only_UTF8(bigstr);
4225 if (offset + len > curlen) {
4226 SvGROW(bigstr, offset+len+1);
4227 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4228 SvCUR_set(bigstr, offset+len);
4232 i = littlelen - len;
4233 if (i > 0) { /* string might grow */
4234 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4235 mid = big + offset + len;
4236 midend = bigend = big + SvCUR(bigstr);
4239 while (midend > mid) /* shove everything down */
4240 *--bigend = *--midend;
4241 Move(little,big+offset,littlelen,char);
4247 Move(little,SvPVX(bigstr)+offset,len,char);
4252 big = SvPVX(bigstr);
4255 bigend = big + SvCUR(bigstr);
4257 if (midend > bigend)
4258 Perl_croak(aTHX_ "panic: sv_insert");
4260 if (mid - big > bigend - midend) { /* faster to shorten from end */
4262 Move(little, mid, littlelen,char);
4265 i = bigend - midend;
4267 Move(midend, mid, i,char);
4271 SvCUR_set(bigstr, mid - big);
4274 else if ((i = mid - big)) { /* faster from front */
4275 midend -= littlelen;
4277 sv_chop(bigstr,midend-i);
4282 Move(little, mid, littlelen,char);
4284 else if (littlelen) {
4285 midend -= littlelen;
4286 sv_chop(bigstr,midend);
4287 Move(little,midend,littlelen,char);
4290 sv_chop(bigstr,midend);
4296 =for apidoc sv_replace
4298 Make the first argument a copy of the second, then delete the original.
4304 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4306 U32 refcnt = SvREFCNT(sv);
4307 SV_CHECK_THINKFIRST(sv);
4308 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4309 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4310 if (SvMAGICAL(sv)) {
4314 sv_upgrade(nsv, SVt_PVMG);
4315 SvMAGIC(nsv) = SvMAGIC(sv);
4316 SvFLAGS(nsv) |= SvMAGICAL(sv);
4322 assert(!SvREFCNT(sv));
4323 StructCopy(nsv,sv,SV);
4324 SvREFCNT(sv) = refcnt;
4325 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4330 =for apidoc sv_clear
4332 Clear an SV, making it empty. Does not free the memory used by the SV
4339 Perl_sv_clear(pTHX_ register SV *sv)
4343 assert(SvREFCNT(sv) == 0);
4346 if (PL_defstash) { /* Still have a symbol table? */
4351 Zero(&tmpref, 1, SV);
4352 sv_upgrade(&tmpref, SVt_RV);
4354 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4355 SvREFCNT(&tmpref) = 1;
4358 stash = SvSTASH(sv);
4359 destructor = StashHANDLER(stash,DESTROY);
4362 PUSHSTACKi(PERLSI_DESTROY);
4363 SvRV(&tmpref) = SvREFCNT_inc(sv);
4368 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4374 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4376 del_XRV(SvANY(&tmpref));
4379 if (PL_in_clean_objs)
4380 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4382 /* DESTROY gave object new lease on life */
4388 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4389 SvOBJECT_off(sv); /* Curse the object. */
4390 if (SvTYPE(sv) != SVt_PVIO)
4391 --PL_sv_objcount; /* XXX Might want something more general */
4394 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4397 switch (SvTYPE(sv)) {
4400 IoIFP(sv) != PerlIO_stdin() &&
4401 IoIFP(sv) != PerlIO_stdout() &&
4402 IoIFP(sv) != PerlIO_stderr())
4404 io_close((IO*)sv, FALSE);
4406 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4407 PerlDir_close(IoDIRP(sv));
4408 IoDIRP(sv) = (DIR*)NULL;
4409 Safefree(IoTOP_NAME(sv));
4410 Safefree(IoFMT_NAME(sv));
4411 Safefree(IoBOTTOM_NAME(sv));
4426 SvREFCNT_dec(LvTARG(sv));
4430 Safefree(GvNAME(sv));
4431 /* cannot decrease stash refcount yet, as we might recursively delete
4432 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4433 of stash until current sv is completely gone.
4434 -- JohnPC, 27 Mar 1998 */
4435 stash = GvSTASH(sv);
4441 (void)SvOOK_off(sv);
4449 SvREFCNT_dec(SvRV(sv));
4451 else if (SvPVX(sv) && SvLEN(sv))
4452 Safefree(SvPVX(sv));
4453 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4454 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4466 switch (SvTYPE(sv)) {
4482 del_XPVIV(SvANY(sv));
4485 del_XPVNV(SvANY(sv));
4488 del_XPVMG(SvANY(sv));
4491 del_XPVLV(SvANY(sv));
4494 del_XPVAV(SvANY(sv));
4497 del_XPVHV(SvANY(sv));
4500 del_XPVCV(SvANY(sv));
4503 del_XPVGV(SvANY(sv));
4504 /* code duplication for increased performance. */
4505 SvFLAGS(sv) &= SVf_BREAK;
4506 SvFLAGS(sv) |= SVTYPEMASK;
4507 /* decrease refcount of the stash that owns this GV, if any */
4509 SvREFCNT_dec(stash);
4510 return; /* not break, SvFLAGS reset already happened */
4512 del_XPVBM(SvANY(sv));
4515 del_XPVFM(SvANY(sv));
4518 del_XPVIO(SvANY(sv));
4521 SvFLAGS(sv) &= SVf_BREAK;
4522 SvFLAGS(sv) |= SVTYPEMASK;
4526 Perl_sv_newref(pTHX_ SV *sv)
4529 ATOMIC_INC(SvREFCNT(sv));
4536 Free the memory used by an SV.
4542 Perl_sv_free(pTHX_ SV *sv)
4544 int refcount_is_zero;
4548 if (SvREFCNT(sv) == 0) {
4549 if (SvFLAGS(sv) & SVf_BREAK)
4551 if (PL_in_clean_all) /* All is fair */
4553 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4554 /* make sure SvREFCNT(sv)==0 happens very seldom */
4555 SvREFCNT(sv) = (~(U32)0)/2;
4558 if (ckWARN_d(WARN_INTERNAL))
4559 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4562 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4563 if (!refcount_is_zero)
4567 if (ckWARN_d(WARN_DEBUGGING))
4568 Perl_warner(aTHX_ WARN_DEBUGGING,
4569 "Attempt to free temp prematurely: SV 0x%"UVxf,
4574 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4575 /* make sure SvREFCNT(sv)==0 happens very seldom */
4576 SvREFCNT(sv) = (~(U32)0)/2;
4587 Returns the length of the string in the SV. See also C<SvCUR>.
4593 Perl_sv_len(pTHX_ register SV *sv)
4602 len = mg_length(sv);
4604 junk = SvPV(sv, len);
4609 =for apidoc sv_len_utf8
4611 Returns the number of characters in the string in an SV, counting wide
4612 UTF8 bytes as a single character.
4618 Perl_sv_len_utf8(pTHX_ register SV *sv)
4624 return mg_length(sv);
4628 U8 *s = (U8*)SvPV(sv, len);
4630 return Perl_utf8_length(aTHX_ s, s + len);
4635 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4640 I32 uoffset = *offsetp;
4646 start = s = (U8*)SvPV(sv, len);
4648 while (s < send && uoffset--)
4652 *offsetp = s - start;
4656 while (s < send && ulen--)
4666 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4675 s = (U8*)SvPV(sv, len);
4677 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4678 send = s + *offsetp;
4683 if (utf8_to_uv(s, UTF8SKIP(s), &n, 0)) {
4697 Returns a boolean indicating whether the strings in the two SVs are
4704 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4711 bool pv1tmp = FALSE;
4712 bool pv2tmp = FALSE;
4719 pv1 = SvPV(sv1, cur1);
4726 pv2 = SvPV(sv2, cur2);
4728 /* do not utf8ize the comparands as a side-effect */
4729 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4730 bool is_utf8 = TRUE;
4732 if (PL_hints & HINT_UTF8_DISTINCT)
4736 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4738 if ((pv1tmp = (pv != pv1)))
4742 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4744 if ((pv2tmp = (pv != pv2)))
4750 eq = memEQ(pv1, pv2, cur1);
4763 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4764 string in C<sv1> is less than, equal to, or greater than the string in
4771 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4776 bool pv1tmp = FALSE;
4777 bool pv2tmp = FALSE;
4784 pv1 = SvPV(sv1, cur1);
4791 pv2 = SvPV(sv2, cur2);
4793 /* do not utf8ize the comparands as a side-effect */
4794 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4795 if (PL_hints & HINT_UTF8_DISTINCT)
4796 return SvUTF8(sv1) ? 1 : -1;
4799 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4803 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4809 cmp = cur2 ? -1 : 0;
4813 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4816 cmp = retval < 0 ? -1 : 1;
4817 } else if (cur1 == cur2) {
4820 cmp = cur1 < cur2 ? -1 : 1;
4833 =for apidoc sv_cmp_locale
4835 Compares the strings in two SVs in a locale-aware manner. See
4842 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4844 #ifdef USE_LOCALE_COLLATE
4850 if (PL_collation_standard)
4854 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4856 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4858 if (!pv1 || !len1) {
4869 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4872 return retval < 0 ? -1 : 1;
4875 * When the result of collation is equality, that doesn't mean
4876 * that there are no differences -- some locales exclude some
4877 * characters from consideration. So to avoid false equalities,
4878 * we use the raw string as a tiebreaker.
4884 #endif /* USE_LOCALE_COLLATE */
4886 return sv_cmp(sv1, sv2);
4889 #ifdef USE_LOCALE_COLLATE
4891 * Any scalar variable may carry an 'o' magic that contains the
4892 * scalar data of the variable transformed to such a format that
4893 * a normal memory comparison can be used to compare the data
4894 * according to the locale settings.
4897 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4901 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4902 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4907 Safefree(mg->mg_ptr);
4909 if ((xf = mem_collxfrm(s, len, &xlen))) {
4910 if (SvREADONLY(sv)) {
4913 return xf + sizeof(PL_collation_ix);
4916 sv_magic(sv, 0, 'o', 0, 0);
4917 mg = mg_find(sv, 'o');
4930 if (mg && mg->mg_ptr) {
4932 return mg->mg_ptr + sizeof(PL_collation_ix);
4940 #endif /* USE_LOCALE_COLLATE */
4945 Get a line from the filehandle and store it into the SV, optionally
4946 appending to the currently-stored string.
4952 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4956 register STDCHAR rslast;
4957 register STDCHAR *bp;
4961 SV_CHECK_THINKFIRST(sv);
4962 (void)SvUPGRADE(sv, SVt_PV);
4966 if (RsSNARF(PL_rs)) {
4970 else if (RsRECORD(PL_rs)) {
4971 I32 recsize, bytesread;
4974 /* Grab the size of the record we're getting */
4975 recsize = SvIV(SvRV(PL_rs));
4976 (void)SvPOK_only(sv); /* Validate pointer */
4977 buffer = SvGROW(sv, recsize + 1);
4980 /* VMS wants read instead of fread, because fread doesn't respect */
4981 /* RMS record boundaries. This is not necessarily a good thing to be */
4982 /* doing, but we've got no other real choice */
4983 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4985 bytesread = PerlIO_read(fp, buffer, recsize);
4987 SvCUR_set(sv, bytesread);
4988 buffer[bytesread] = '\0';
4989 if (PerlIO_isutf8(fp))
4993 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4995 else if (RsPARA(PL_rs)) {
5000 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5001 if (PerlIO_isutf8(fp)) {
5002 rsptr = SvPVutf8(PL_rs, rslen);
5005 if (SvUTF8(PL_rs)) {
5006 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5007 Perl_croak(aTHX_ "Wide character in $/");
5010 rsptr = SvPV(PL_rs, rslen);
5014 rslast = rslen ? rsptr[rslen - 1] : '\0';
5016 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5017 do { /* to make sure file boundaries work right */
5020 i = PerlIO_getc(fp);
5024 PerlIO_ungetc(fp,i);
5030 /* See if we know enough about I/O mechanism to cheat it ! */
5032 /* This used to be #ifdef test - it is made run-time test for ease
5033 of abstracting out stdio interface. One call should be cheap
5034 enough here - and may even be a macro allowing compile
5038 if (PerlIO_fast_gets(fp)) {
5041 * We're going to steal some values from the stdio struct
5042 * and put EVERYTHING in the innermost loop into registers.
5044 register STDCHAR *ptr;
5048 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5049 /* An ungetc()d char is handled separately from the regular
5050 * buffer, so we getc() it back out and stuff it in the buffer.
5052 i = PerlIO_getc(fp);
5053 if (i == EOF) return 0;
5054 *(--((*fp)->_ptr)) = (unsigned char) i;
5058 /* Here is some breathtakingly efficient cheating */
5060 cnt = PerlIO_get_cnt(fp); /* get count into register */
5061 (void)SvPOK_only(sv); /* validate pointer */
5062 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5063 if (cnt > 80 && SvLEN(sv) > append) {
5064 shortbuffered = cnt - SvLEN(sv) + append + 1;
5065 cnt -= shortbuffered;
5069 /* remember that cnt can be negative */
5070 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5075 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5076 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5077 DEBUG_P(PerlIO_printf(Perl_debug_log,
5078 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5079 DEBUG_P(PerlIO_printf(Perl_debug_log,
5080 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5081 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5082 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5087 while (cnt > 0) { /* this | eat */
5089 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5090 goto thats_all_folks; /* screams | sed :-) */
5094 Copy(ptr, bp, cnt, char); /* this | eat */
5095 bp += cnt; /* screams | dust */
5096 ptr += cnt; /* louder | sed :-) */
5101 if (shortbuffered) { /* oh well, must extend */
5102 cnt = shortbuffered;
5104 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5106 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5107 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5111 DEBUG_P(PerlIO_printf(Perl_debug_log,
5112 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5113 PTR2UV(ptr),(long)cnt));
5114 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5115 DEBUG_P(PerlIO_printf(Perl_debug_log,
5116 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5117 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5118 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5119 /* This used to call 'filbuf' in stdio form, but as that behaves like
5120 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5121 another abstraction. */
5122 i = PerlIO_getc(fp); /* get more characters */
5123 DEBUG_P(PerlIO_printf(Perl_debug_log,
5124 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5125 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5126 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5127 cnt = PerlIO_get_cnt(fp);
5128 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5129 DEBUG_P(PerlIO_printf(Perl_debug_log,
5130 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5132 if (i == EOF) /* all done for ever? */
5133 goto thats_really_all_folks;
5135 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5137 SvGROW(sv, bpx + cnt + 2);
5138 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5140 *bp++ = i; /* store character from PerlIO_getc */
5142 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5143 goto thats_all_folks;
5147 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5148 memNE((char*)bp - rslen, rsptr, rslen))
5149 goto screamer; /* go back to the fray */
5150 thats_really_all_folks:
5152 cnt += shortbuffered;
5153 DEBUG_P(PerlIO_printf(Perl_debug_log,
5154 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5155 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5156 DEBUG_P(PerlIO_printf(Perl_debug_log,
5157 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5158 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5159 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5161 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5162 DEBUG_P(PerlIO_printf(Perl_debug_log,
5163 "Screamer: done, len=%ld, string=|%.*s|\n",
5164 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5169 /*The big, slow, and stupid way */
5172 /* Need to work around EPOC SDK features */
5173 /* On WINS: MS VC5 generates calls to _chkstk, */
5174 /* if a `large' stack frame is allocated */
5175 /* gcc on MARM does not generate calls like these */
5181 register STDCHAR *bpe = buf + sizeof(buf);
5183 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5184 ; /* keep reading */
5188 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5189 /* Accomodate broken VAXC compiler, which applies U8 cast to
5190 * both args of ?: operator, causing EOF to change into 255
5192 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5196 sv_catpvn(sv, (char *) buf, cnt);
5198 sv_setpvn(sv, (char *) buf, cnt);
5200 if (i != EOF && /* joy */
5202 SvCUR(sv) < rslen ||
5203 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5207 * If we're reading from a TTY and we get a short read,
5208 * indicating that the user hit his EOF character, we need
5209 * to notice it now, because if we try to read from the TTY
5210 * again, the EOF condition will disappear.
5212 * The comparison of cnt to sizeof(buf) is an optimization
5213 * that prevents unnecessary calls to feof().
5217 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5222 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5223 while (i != EOF) { /* to make sure file boundaries work right */
5224 i = PerlIO_getc(fp);
5226 PerlIO_ungetc(fp,i);
5232 if (PerlIO_isutf8(fp))
5237 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5244 Auto-increment of the value in the SV.
5250 Perl_sv_inc(pTHX_ register SV *sv)
5259 if (SvTHINKFIRST(sv)) {
5260 if (SvREADONLY(sv)) {
5261 if (PL_curcop != &PL_compiling)
5262 Perl_croak(aTHX_ PL_no_modify);
5266 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5268 i = PTR2IV(SvRV(sv));
5273 flags = SvFLAGS(sv);
5274 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5275 /* It's (privately or publicly) a float, but not tested as an
5276 integer, so test it to see. */
5278 flags = SvFLAGS(sv);
5280 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5281 /* It's publicly an integer, or privately an integer-not-float */
5284 if (SvUVX(sv) == UV_MAX)
5285 sv_setnv(sv, (NV)UV_MAX + 1.0);
5287 (void)SvIOK_only_UV(sv);
5290 if (SvIVX(sv) == IV_MAX)
5291 sv_setuv(sv, (UV)IV_MAX + 1);
5293 (void)SvIOK_only(sv);
5299 if (flags & SVp_NOK) {
5300 (void)SvNOK_only(sv);
5305 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5306 if ((flags & SVTYPEMASK) < SVt_PVIV)
5307 sv_upgrade(sv, SVt_IV);
5308 (void)SvIOK_only(sv);
5313 while (isALPHA(*d)) d++;
5314 while (isDIGIT(*d)) d++;
5316 #ifdef PERL_PRESERVE_IVUV
5317 /* Got to punt this an an integer if needs be, but we don't issue
5318 warnings. Probably ought to make the sv_iv_please() that does
5319 the conversion if possible, and silently. */
5320 I32 numtype = looks_like_number(sv);
5321 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5322 /* Need to try really hard to see if it's an integer.
5323 9.22337203685478e+18 is an integer.
5324 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5325 so $a="9.22337203685478e+18"; $a+0; $a++
5326 needs to be the same as $a="9.22337203685478e+18"; $a++
5333 /* sv_2iv *should* have made this an NV */
5334 if (flags & SVp_NOK) {
5335 (void)SvNOK_only(sv);
5339 /* I don't think we can get here. Maybe I should assert this
5340 And if we do get here I suspect that sv_setnv will croak. NWC
5342 #if defined(USE_LONG_DOUBLE)
5343 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",
5344 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5346 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5347 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5350 #endif /* PERL_PRESERVE_IVUV */
5351 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5355 while (d >= SvPVX(sv)) {
5363 /* MKS: The original code here died if letters weren't consecutive.
5364 * at least it didn't have to worry about non-C locales. The
5365 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5366 * arranged in order (although not consecutively) and that only
5367 * [A-Za-z] are accepted by isALPHA in the C locale.
5369 if (*d != 'z' && *d != 'Z') {
5370 do { ++*d; } while (!isALPHA(*d));
5373 *(d--) -= 'z' - 'a';
5378 *(d--) -= 'z' - 'a' + 1;
5382 /* oh,oh, the number grew */
5383 SvGROW(sv, SvCUR(sv) + 2);
5385 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5396 Auto-decrement of the value in the SV.
5402 Perl_sv_dec(pTHX_ register SV *sv)
5410 if (SvTHINKFIRST(sv)) {
5411 if (SvREADONLY(sv)) {
5412 if (PL_curcop != &PL_compiling)
5413 Perl_croak(aTHX_ PL_no_modify);
5417 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5419 i = PTR2IV(SvRV(sv));
5424 /* Unlike sv_inc we don't have to worry about string-never-numbers
5425 and keeping them magic. But we mustn't warn on punting */
5426 flags = SvFLAGS(sv);
5427 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5428 /* It's publicly an integer, or privately an integer-not-float */
5431 if (SvUVX(sv) == 0) {
5432 (void)SvIOK_only(sv);
5436 (void)SvIOK_only_UV(sv);
5440 if (SvIVX(sv) == IV_MIN)
5441 sv_setnv(sv, (NV)IV_MIN - 1.0);
5443 (void)SvIOK_only(sv);
5449 if (flags & SVp_NOK) {
5451 (void)SvNOK_only(sv);
5454 if (!(flags & SVp_POK)) {
5455 if ((flags & SVTYPEMASK) < SVt_PVNV)
5456 sv_upgrade(sv, SVt_NV);
5458 (void)SvNOK_only(sv);
5461 #ifdef PERL_PRESERVE_IVUV
5463 I32 numtype = looks_like_number(sv);
5464 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5465 /* Need to try really hard to see if it's an integer.
5466 9.22337203685478e+18 is an integer.
5467 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5468 so $a="9.22337203685478e+18"; $a+0; $a--
5469 needs to be the same as $a="9.22337203685478e+18"; $a--
5476 /* sv_2iv *should* have made this an NV */
5477 if (flags & SVp_NOK) {
5478 (void)SvNOK_only(sv);
5482 /* I don't think we can get here. Maybe I should assert this
5483 And if we do get here I suspect that sv_setnv will croak. NWC
5485 #if defined(USE_LONG_DOUBLE)
5486 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",
5487 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5489 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5490 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5494 #endif /* PERL_PRESERVE_IVUV */
5495 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5499 =for apidoc sv_mortalcopy
5501 Creates a new SV which is a copy of the original SV. The new SV is marked
5507 /* Make a string that will exist for the duration of the expression
5508 * evaluation. Actually, it may have to last longer than that, but
5509 * hopefully we won't free it until it has been assigned to a
5510 * permanent location. */
5513 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5518 sv_setsv(sv,oldstr);
5520 PL_tmps_stack[++PL_tmps_ix] = sv;
5526 =for apidoc sv_newmortal
5528 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5534 Perl_sv_newmortal(pTHX)
5539 SvFLAGS(sv) = SVs_TEMP;
5541 PL_tmps_stack[++PL_tmps_ix] = sv;
5546 =for apidoc sv_2mortal
5548 Marks an SV as mortal. The SV will be destroyed when the current context
5554 /* same thing without the copying */
5557 Perl_sv_2mortal(pTHX_ register SV *sv)
5561 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5564 PL_tmps_stack[++PL_tmps_ix] = sv;
5572 Creates a new SV and copies a string into it. The reference count for the
5573 SV is set to 1. If C<len> is zero, Perl will compute the length using
5574 strlen(). For efficiency, consider using C<newSVpvn> instead.
5580 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5587 sv_setpvn(sv,s,len);
5592 =for apidoc newSVpvn
5594 Creates a new SV and copies a string into it. The reference count for the
5595 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5596 string. You are responsible for ensuring that the source string is at least
5603 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5608 sv_setpvn(sv,s,len);
5613 =for apidoc newSVpvn_share
5615 Creates a new SV and populates it with a string from
5616 the string table. Turns on READONLY and FAKE.
5617 The idea here is that as string table is used for shared hash
5618 keys these strings will have SvPVX == HeKEY and hash lookup
5619 will avoid string compare.
5625 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5628 bool is_utf8 = FALSE;
5633 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5634 STRLEN tmplen = len;
5635 /* See the note in hv.c:hv_fetch() --jhi */
5636 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5640 PERL_HASH(hash, src, len);
5642 sv_upgrade(sv, SVt_PVIV);
5643 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5655 #if defined(PERL_IMPLICIT_CONTEXT)
5657 Perl_newSVpvf_nocontext(const char* pat, ...)
5662 va_start(args, pat);
5663 sv = vnewSVpvf(pat, &args);
5670 =for apidoc newSVpvf
5672 Creates a new SV an initialize it with the string formatted like
5679 Perl_newSVpvf(pTHX_ const char* pat, ...)
5683 va_start(args, pat);
5684 sv = vnewSVpvf(pat, &args);
5690 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5694 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5701 Creates a new SV and copies a floating point value into it.
5702 The reference count for the SV is set to 1.
5708 Perl_newSVnv(pTHX_ NV n)
5720 Creates a new SV and copies an integer into it. The reference count for the
5727 Perl_newSViv(pTHX_ IV i)
5739 Creates a new SV and copies an unsigned integer into it.
5740 The reference count for the SV is set to 1.
5746 Perl_newSVuv(pTHX_ UV u)
5756 =for apidoc newRV_noinc
5758 Creates an RV wrapper for an SV. The reference count for the original
5759 SV is B<not> incremented.
5765 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5770 sv_upgrade(sv, SVt_RV);
5777 /* newRV_inc is #defined to newRV in sv.h */
5779 Perl_newRV(pTHX_ SV *tmpRef)
5781 return newRV_noinc(SvREFCNT_inc(tmpRef));
5787 Creates a new SV which is an exact duplicate of the original SV.
5792 /* make an exact duplicate of old */
5795 Perl_newSVsv(pTHX_ register SV *old)
5801 if (SvTYPE(old) == SVTYPEMASK) {
5802 if (ckWARN_d(WARN_INTERNAL))
5803 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5818 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5826 char todo[PERL_UCHAR_MAX+1];
5831 if (!*s) { /* reset ?? searches */
5832 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5833 pm->op_pmdynflags &= ~PMdf_USED;
5838 /* reset variables */
5840 if (!HvARRAY(stash))
5843 Zero(todo, 256, char);
5845 i = (unsigned char)*s;
5849 max = (unsigned char)*s++;
5850 for ( ; i <= max; i++) {
5853 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5854 for (entry = HvARRAY(stash)[i];
5856 entry = HeNEXT(entry))
5858 if (!todo[(U8)*HeKEY(entry)])
5860 gv = (GV*)HeVAL(entry);
5862 if (SvTHINKFIRST(sv)) {
5863 if (!SvREADONLY(sv) && SvROK(sv))
5868 if (SvTYPE(sv) >= SVt_PV) {
5870 if (SvPVX(sv) != Nullch)
5877 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5879 #ifdef USE_ENVIRON_ARRAY
5881 environ[0] = Nullch;
5890 Perl_sv_2io(pTHX_ SV *sv)
5896 switch (SvTYPE(sv)) {
5904 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5908 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5910 return sv_2io(SvRV(sv));
5911 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5917 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5924 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5931 return *gvp = Nullgv, Nullcv;
5932 switch (SvTYPE(sv)) {
5951 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5952 tryAMAGICunDEREF(to_cv);
5955 if (SvTYPE(sv) == SVt_PVCV) {
5964 Perl_croak(aTHX_ "Not a subroutine reference");
5969 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5975 if (lref && !GvCVu(gv)) {
5978 tmpsv = NEWSV(704,0);
5979 gv_efullname3(tmpsv, gv, Nullch);
5980 /* XXX this is probably not what they think they're getting.
5981 * It has the same effect as "sub name;", i.e. just a forward
5983 newSUB(start_subparse(FALSE, 0),
5984 newSVOP(OP_CONST, 0, tmpsv),
5989 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5998 Returns true if the SV has a true value by Perl's rules.
6004 Perl_sv_true(pTHX_ register SV *sv)
6010 if ((tXpv = (XPV*)SvANY(sv)) &&
6011 (tXpv->xpv_cur > 1 ||
6012 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6019 return SvIVX(sv) != 0;
6022 return SvNVX(sv) != 0.0;
6024 return sv_2bool(sv);
6030 Perl_sv_iv(pTHX_ register SV *sv)
6034 return (IV)SvUVX(sv);
6041 Perl_sv_uv(pTHX_ register SV *sv)
6046 return (UV)SvIVX(sv);
6052 Perl_sv_nv(pTHX_ register SV *sv)
6060 Perl_sv_pv(pTHX_ SV *sv)
6067 return sv_2pv(sv, &n_a);
6071 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6077 return sv_2pv(sv, lp);
6081 =for apidoc sv_pvn_force
6083 Get a sensible string out of the SV somehow.
6089 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6093 if (SvTHINKFIRST(sv) && !SvROK(sv))
6094 sv_force_normal(sv);
6100 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6101 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6102 PL_op_name[PL_op->op_type]);
6106 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6111 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6112 SvGROW(sv, len + 1);
6113 Move(s,SvPVX(sv),len,char);
6118 SvPOK_on(sv); /* validate pointer */
6120 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6121 PTR2UV(sv),SvPVX(sv)));
6128 Perl_sv_pvbyte(pTHX_ SV *sv)
6134 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6136 return sv_pvn(sv,lp);
6140 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6142 return sv_pvn_force(sv,lp);
6146 Perl_sv_pvutf8(pTHX_ SV *sv)
6148 sv_utf8_upgrade(sv);
6153 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6155 sv_utf8_upgrade(sv);
6156 return sv_pvn(sv,lp);
6160 =for apidoc sv_pvutf8n_force
6162 Get a sensible UTF8-encoded string out of the SV somehow. See
6169 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6171 sv_utf8_upgrade(sv);
6172 return sv_pvn_force(sv,lp);
6176 =for apidoc sv_reftype
6178 Returns a string describing what the SV is a reference to.
6184 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6186 if (ob && SvOBJECT(sv))
6187 return HvNAME(SvSTASH(sv));
6189 switch (SvTYPE(sv)) {
6203 case SVt_PVLV: return "LVALUE";
6204 case SVt_PVAV: return "ARRAY";
6205 case SVt_PVHV: return "HASH";
6206 case SVt_PVCV: return "CODE";
6207 case SVt_PVGV: return "GLOB";
6208 case SVt_PVFM: return "FORMAT";
6209 case SVt_PVIO: return "IO";
6210 default: return "UNKNOWN";
6216 =for apidoc sv_isobject
6218 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6219 object. If the SV is not an RV, or if the object is not blessed, then this
6226 Perl_sv_isobject(pTHX_ SV *sv)
6243 Returns a boolean indicating whether the SV is blessed into the specified
6244 class. This does not check for subtypes; use C<sv_derived_from> to verify
6245 an inheritance relationship.
6251 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6263 return strEQ(HvNAME(SvSTASH(sv)), name);
6269 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6270 it will be upgraded to one. If C<classname> is non-null then the new SV will
6271 be blessed in the specified package. The new SV is returned and its
6272 reference count is 1.
6278 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6284 SV_CHECK_THINKFIRST(rv);
6287 if (SvTYPE(rv) >= SVt_PVMG) {
6288 U32 refcnt = SvREFCNT(rv);
6292 SvREFCNT(rv) = refcnt;
6295 if (SvTYPE(rv) < SVt_RV)
6296 sv_upgrade(rv, SVt_RV);
6297 else if (SvTYPE(rv) > SVt_RV) {
6298 (void)SvOOK_off(rv);
6299 if (SvPVX(rv) && SvLEN(rv))
6300 Safefree(SvPVX(rv));
6310 HV* stash = gv_stashpv(classname, TRUE);
6311 (void)sv_bless(rv, stash);
6317 =for apidoc sv_setref_pv
6319 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6320 argument will be upgraded to an RV. That RV will be modified to point to
6321 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6322 into the SV. The C<classname> argument indicates the package for the
6323 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6324 will be returned and will have a reference count of 1.
6326 Do not use with other Perl types such as HV, AV, SV, CV, because those
6327 objects will become corrupted by the pointer copy process.
6329 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6335 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6338 sv_setsv(rv, &PL_sv_undef);
6342 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6347 =for apidoc sv_setref_iv
6349 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6350 argument will be upgraded to an RV. That RV will be modified to point to
6351 the new SV. The C<classname> argument indicates the package for the
6352 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6353 will be returned and will have a reference count of 1.
6359 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6361 sv_setiv(newSVrv(rv,classname), iv);
6366 =for apidoc sv_setref_uv
6368 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6369 argument will be upgraded to an RV. That RV will be modified to point to
6370 the new SV. The C<classname> argument indicates the package for the
6371 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6372 will be returned and will have a reference count of 1.
6378 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6380 sv_setuv(newSVrv(rv,classname), uv);
6385 =for apidoc sv_setref_nv
6387 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6388 argument will be upgraded to an RV. That RV will be modified to point to
6389 the new SV. The C<classname> argument indicates the package for the
6390 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6391 will be returned and will have a reference count of 1.
6397 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6399 sv_setnv(newSVrv(rv,classname), nv);
6404 =for apidoc sv_setref_pvn
6406 Copies a string into a new SV, optionally blessing the SV. The length of the
6407 string must be specified with C<n>. The C<rv> argument will be upgraded to
6408 an RV. That RV will be modified to point to the new SV. The C<classname>
6409 argument indicates the package for the blessing. Set C<classname> to
6410 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6411 a reference count of 1.
6413 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6419 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6421 sv_setpvn(newSVrv(rv,classname), pv, n);
6426 =for apidoc sv_bless
6428 Blesses an SV into a specified package. The SV must be an RV. The package
6429 must be designated by its stash (see C<gv_stashpv()>). The reference count
6430 of the SV is unaffected.
6436 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6440 Perl_croak(aTHX_ "Can't bless non-reference value");
6442 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6443 if (SvREADONLY(tmpRef))
6444 Perl_croak(aTHX_ PL_no_modify);
6445 if (SvOBJECT(tmpRef)) {
6446 if (SvTYPE(tmpRef) != SVt_PVIO)
6448 SvREFCNT_dec(SvSTASH(tmpRef));
6451 SvOBJECT_on(tmpRef);
6452 if (SvTYPE(tmpRef) != SVt_PVIO)
6454 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6455 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6466 S_sv_unglob(pTHX_ SV *sv)
6470 assert(SvTYPE(sv) == SVt_PVGV);
6475 SvREFCNT_dec(GvSTASH(sv));
6476 GvSTASH(sv) = Nullhv;
6478 sv_unmagic(sv, '*');
6479 Safefree(GvNAME(sv));
6482 /* need to keep SvANY(sv) in the right arena */
6483 xpvmg = new_XPVMG();
6484 StructCopy(SvANY(sv), xpvmg, XPVMG);
6485 del_XPVGV(SvANY(sv));
6488 SvFLAGS(sv) &= ~SVTYPEMASK;
6489 SvFLAGS(sv) |= SVt_PVMG;
6493 =for apidoc sv_unref_flags
6495 Unsets the RV status of the SV, and decrements the reference count of
6496 whatever was being referenced by the RV. This can almost be thought of
6497 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6498 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6499 (otherwise the decrementing is conditional on the reference count being
6500 different from one or the reference being a readonly SV).
6507 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6511 if (SvWEAKREF(sv)) {
6519 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6521 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6522 sv_2mortal(rv); /* Schedule for freeing later */
6526 =for apidoc sv_unref
6528 Unsets the RV status of the SV, and decrements the reference count of
6529 whatever was being referenced by the RV. This can almost be thought of
6530 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6531 being zero. See C<SvROK_off>.
6537 Perl_sv_unref(pTHX_ SV *sv)
6539 sv_unref_flags(sv, 0);
6543 Perl_sv_taint(pTHX_ SV *sv)
6545 sv_magic((sv), Nullsv, 't', Nullch, 0);
6549 Perl_sv_untaint(pTHX_ SV *sv)
6551 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6552 MAGIC *mg = mg_find(sv, 't');
6559 Perl_sv_tainted(pTHX_ SV *sv)
6561 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6562 MAGIC *mg = mg_find(sv, 't');
6563 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6570 =for apidoc sv_setpviv
6572 Copies an integer into the given SV, also updating its string value.
6573 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6579 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6581 char buf[TYPE_CHARS(UV)];
6583 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6585 sv_setpvn(sv, ptr, ebuf - ptr);
6590 =for apidoc sv_setpviv_mg
6592 Like C<sv_setpviv>, but also handles 'set' magic.
6598 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6600 char buf[TYPE_CHARS(UV)];
6602 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6604 sv_setpvn(sv, ptr, ebuf - ptr);
6608 #if defined(PERL_IMPLICIT_CONTEXT)
6610 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6614 va_start(args, pat);
6615 sv_vsetpvf(sv, pat, &args);
6621 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6625 va_start(args, pat);
6626 sv_vsetpvf_mg(sv, pat, &args);
6632 =for apidoc sv_setpvf
6634 Processes its arguments like C<sprintf> and sets an SV to the formatted
6635 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6641 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6644 va_start(args, pat);
6645 sv_vsetpvf(sv, pat, &args);
6650 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6652 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6656 =for apidoc sv_setpvf_mg
6658 Like C<sv_setpvf>, but also handles 'set' magic.
6664 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6667 va_start(args, pat);
6668 sv_vsetpvf_mg(sv, pat, &args);
6673 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6675 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6679 #if defined(PERL_IMPLICIT_CONTEXT)
6681 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6685 va_start(args, pat);
6686 sv_vcatpvf(sv, pat, &args);
6691 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6695 va_start(args, pat);
6696 sv_vcatpvf_mg(sv, pat, &args);
6702 =for apidoc sv_catpvf
6704 Processes its arguments like C<sprintf> and appends the formatted output
6705 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6706 typically be called after calling this function to handle 'set' magic.
6712 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6715 va_start(args, pat);
6716 sv_vcatpvf(sv, pat, &args);
6721 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6723 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6727 =for apidoc sv_catpvf_mg
6729 Like C<sv_catpvf>, but also handles 'set' magic.
6735 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6738 va_start(args, pat);
6739 sv_vcatpvf_mg(sv, pat, &args);
6744 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6746 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6751 =for apidoc sv_vsetpvfn
6753 Works like C<vcatpvfn> but copies the text into the SV instead of
6760 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6762 sv_setpvn(sv, "", 0);
6763 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6767 S_expect_number(pTHX_ char** pattern)
6770 switch (**pattern) {
6771 case '1': case '2': case '3':
6772 case '4': case '5': case '6':
6773 case '7': case '8': case '9':
6774 while (isDIGIT(**pattern))
6775 var = var * 10 + (*(*pattern)++ - '0');
6779 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6782 =for apidoc sv_vcatpvfn
6784 Processes its arguments like C<vsprintf> and appends the formatted output
6785 to an SV. Uses an array of SVs if the C style variable argument list is
6786 missing (NULL). When running with taint checks enabled, indicates via
6787 C<maybe_tainted> if results are untrustworthy (often due to the use of
6794 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6801 static char nullstr[] = "(null)";
6804 /* no matter what, this is a string now */
6805 (void)SvPV_force(sv, origlen);
6807 /* special-case "", "%s", and "%_" */
6810 if (patlen == 2 && pat[0] == '%') {
6814 char *s = va_arg(*args, char*);
6815 sv_catpv(sv, s ? s : nullstr);
6817 else if (svix < svmax) {
6818 sv_catsv(sv, *svargs);
6819 if (DO_UTF8(*svargs))
6825 argsv = va_arg(*args, SV*);
6826 sv_catsv(sv, argsv);
6831 /* See comment on '_' below */
6836 patend = (char*)pat + patlen;
6837 for (p = (char*)pat; p < patend; p = q) {
6840 bool vectorize = FALSE;
6841 bool vectorarg = FALSE;
6842 bool vec_utf = FALSE;
6848 bool has_precis = FALSE;
6850 bool is_utf = FALSE;
6853 U8 utf8buf[UTF8_MAXLEN+1];
6854 STRLEN esignlen = 0;
6856 char *eptr = Nullch;
6858 /* Times 4: a decimal digit takes more than 3 binary digits.
6859 * NV_DIG: mantissa takes than many decimal digits.
6860 * Plus 32: Playing safe. */
6861 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6862 /* large enough for "%#.#f" --chip */
6863 /* what about long double NVs? --jhi */
6866 U8 *vecstr = Null(U8*);
6878 STRLEN dotstrlen = 1;
6879 I32 efix = 0; /* explicit format parameter index */
6880 I32 ewix = 0; /* explicit width index */
6881 I32 epix = 0; /* explicit precision index */
6882 I32 evix = 0; /* explicit vector index */
6883 bool asterisk = FALSE;
6885 /* echo everything up to the next format specification */
6886 for (q = p; q < patend && *q != '%'; ++q) ;
6888 sv_catpvn(sv, p, q - p);
6895 We allow format specification elements in this order:
6896 \d+\$ explicit format parameter index
6898 \*?(\d+\$)?v vector with optional (optionally specified) arg
6899 \d+|\*(\d+\$)? width using optional (optionally specified) arg
6900 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
6902 [%bcdefginopsux_DFOUX] format (mandatory)
6904 if (EXPECT_NUMBER(q, width)) {
6945 if (EXPECT_NUMBER(q, ewix))
6954 if ((vectorarg = asterisk)) {
6964 EXPECT_NUMBER(q, width);
6969 vecsv = va_arg(*args, SV*);
6971 vecsv = (evix ? evix <= svmax : svix < svmax) ?
6972 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
6973 dotstr = SvPVx(vecsv, dotstrlen);
6978 vecsv = va_arg(*args, SV*);
6979 vecstr = (U8*)SvPVx(vecsv,veclen);
6980 vec_utf = DO_UTF8(vecsv);
6982 else if (efix ? efix <= svmax : svix < svmax) {
6983 vecsv = svargs[efix ? efix-1 : svix++];
6984 vecstr = (U8*)SvPVx(vecsv,veclen);
6985 vec_utf = DO_UTF8(vecsv);
6995 i = va_arg(*args, int);
6997 i = (ewix ? ewix <= svmax : svix < svmax) ?
6998 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7000 width = (i < 0) ? -i : i;
7010 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7013 i = va_arg(*args, int);
7015 i = (ewix ? ewix <= svmax : svix < svmax)
7016 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7017 precis = (i < 0) ? 0 : i;
7022 precis = precis * 10 + (*q++ - '0');
7030 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7041 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7042 if (*(q + 1) == 'l') { /* lld, llf */
7065 argsv = (efix ? efix <= svmax : svix < svmax) ?
7066 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7073 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7074 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
7075 eptr = (char*)utf8buf;
7076 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
7088 eptr = va_arg(*args, char*);
7090 #ifdef MACOS_TRADITIONAL
7091 /* On MacOS, %#s format is used for Pascal strings */
7096 elen = strlen(eptr);
7099 elen = sizeof nullstr - 1;
7103 eptr = SvPVx(argsv, elen);
7104 if (DO_UTF8(argsv)) {
7105 if (has_precis && precis < elen) {
7107 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7110 if (width) { /* fudge width (can't fudge elen) */
7111 width += elen - sv_len_utf8(argsv);
7120 * The "%_" hack might have to be changed someday,
7121 * if ISO or ANSI decide to use '_' for something.
7122 * So we keep it hidden from users' code.
7126 argsv = va_arg(*args, SV*);
7127 eptr = SvPVx(argsv, elen);
7133 if (has_precis && elen > precis)
7142 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7160 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7170 case 'h': iv = (short)va_arg(*args, int); break;
7171 default: iv = va_arg(*args, int); break;
7172 case 'l': iv = va_arg(*args, long); break;
7173 case 'V': iv = va_arg(*args, IV); break;
7175 case 'q': iv = va_arg(*args, Quad_t); break;
7182 case 'h': iv = (short)iv; break;
7184 case 'l': iv = (long)iv; break;
7187 case 'q': iv = (Quad_t)iv; break;
7194 esignbuf[esignlen++] = plus;
7198 esignbuf[esignlen++] = '-';
7240 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7250 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7251 default: uv = va_arg(*args, unsigned); break;
7252 case 'l': uv = va_arg(*args, unsigned long); break;
7253 case 'V': uv = va_arg(*args, UV); break;
7255 case 'q': uv = va_arg(*args, Quad_t); break;
7262 case 'h': uv = (unsigned short)uv; break;
7264 case 'l': uv = (unsigned long)uv; break;
7267 case 'q': uv = (Quad_t)uv; break;
7273 eptr = ebuf + sizeof ebuf;
7279 p = (char*)((c == 'X')
7280 ? "0123456789ABCDEF" : "0123456789abcdef");
7286 esignbuf[esignlen++] = '0';
7287 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7293 *--eptr = '0' + dig;
7295 if (alt && *eptr != '0')
7301 *--eptr = '0' + dig;
7304 esignbuf[esignlen++] = '0';
7305 esignbuf[esignlen++] = 'b';
7308 default: /* it had better be ten or less */
7309 #if defined(PERL_Y2KWARN)
7310 if (ckWARN(WARN_Y2K)) {
7312 char *s = SvPV(sv,n);
7313 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7314 && (n == 2 || !isDIGIT(s[n-3])))
7316 Perl_warner(aTHX_ WARN_Y2K,
7317 "Possible Y2K bug: %%%c %s",
7318 c, "format string following '19'");
7324 *--eptr = '0' + dig;
7325 } while (uv /= base);
7328 elen = (ebuf + sizeof ebuf) - eptr;
7331 zeros = precis - elen;
7332 else if (precis == 0 && elen == 1 && *eptr == '0')
7337 /* FLOATING POINT */
7340 c = 'f'; /* maybe %F isn't supported here */
7346 /* This is evil, but floating point is even more evil */
7349 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7352 if (c != 'e' && c != 'E') {
7354 (void)Perl_frexp(nv, &i);
7355 if (i == PERL_INT_MIN)
7356 Perl_die(aTHX_ "panic: frexp");
7358 need = BIT_DIGITS(i);
7360 need += has_precis ? precis : 6; /* known default */
7364 need += 20; /* fudge factor */
7365 if (PL_efloatsize < need) {
7366 Safefree(PL_efloatbuf);
7367 PL_efloatsize = need + 20; /* more fudge */
7368 New(906, PL_efloatbuf, PL_efloatsize, char);
7369 PL_efloatbuf[0] = '\0';
7372 eptr = ebuf + sizeof ebuf;
7375 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7377 /* Copy the one or more characters in a long double
7378 * format before the 'base' ([efgEFG]) character to
7379 * the format string. */
7380 static char const prifldbl[] = PERL_PRIfldbl;
7381 char const *p = prifldbl + sizeof(prifldbl) - 3;
7382 while (p >= prifldbl) { *--eptr = *p--; }
7387 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7392 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7404 /* No taint. Otherwise we are in the strange situation
7405 * where printf() taints but print($float) doesn't.
7407 (void)sprintf(PL_efloatbuf, eptr, nv);
7409 eptr = PL_efloatbuf;
7410 elen = strlen(PL_efloatbuf);
7417 i = SvCUR(sv) - origlen;
7420 case 'h': *(va_arg(*args, short*)) = i; break;
7421 default: *(va_arg(*args, int*)) = i; break;
7422 case 'l': *(va_arg(*args, long*)) = i; break;
7423 case 'V': *(va_arg(*args, IV*)) = i; break;
7425 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7430 sv_setuv_mg(argsv, (UV)i);
7431 continue; /* not "break" */
7438 if (!args && ckWARN(WARN_PRINTF) &&
7439 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7440 SV *msg = sv_newmortal();
7441 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7442 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7445 Perl_sv_catpvf(aTHX_ msg,
7446 "\"%%%c\"", c & 0xFF);
7448 Perl_sv_catpvf(aTHX_ msg,
7449 "\"%%\\%03"UVof"\"",
7452 sv_catpv(msg, "end of string");
7453 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7456 /* output mangled stuff ... */
7462 /* ... right here, because formatting flags should not apply */
7463 SvGROW(sv, SvCUR(sv) + elen + 1);
7465 Copy(eptr, p, elen, char);
7468 SvCUR(sv) = p - SvPVX(sv);
7469 continue; /* not "break" */
7472 have = esignlen + zeros + elen;
7473 need = (have > width ? have : width);
7476 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7478 if (esignlen && fill == '0') {
7479 for (i = 0; i < esignlen; i++)
7483 memset(p, fill, gap);
7486 if (esignlen && fill != '0') {
7487 for (i = 0; i < esignlen; i++)
7491 for (i = zeros; i; i--)
7495 Copy(eptr, p, elen, char);
7499 memset(p, ' ', gap);
7504 Copy(dotstr, p, dotstrlen, char);
7508 vectorize = FALSE; /* done iterating over vecstr */
7513 SvCUR(sv) = p - SvPVX(sv);
7521 #if defined(USE_ITHREADS)
7523 #if defined(USE_THREADS)
7524 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7527 #ifndef GpREFCNT_inc
7528 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7532 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7533 #define av_dup(s) (AV*)sv_dup((SV*)s)
7534 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7535 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7536 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7537 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7538 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7539 #define io_dup(s) (IO*)sv_dup((SV*)s)
7540 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7541 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7542 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7543 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7544 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7547 Perl_re_dup(pTHX_ REGEXP *r)
7549 /* XXX fix when pmop->op_pmregexp becomes shared */
7550 return ReREFCNT_inc(r);
7554 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7558 return (PerlIO*)NULL;
7560 /* look for it in the table first */
7561 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7565 /* create anew and remember what it is */
7566 ret = PerlIO_fdupopen(aTHX_ fp);
7567 ptr_table_store(PL_ptr_table, fp, ret);
7572 Perl_dirp_dup(pTHX_ DIR *dp)
7581 Perl_gp_dup(pTHX_ GP *gp)
7586 /* look for it in the table first */
7587 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7591 /* create anew and remember what it is */
7592 Newz(0, ret, 1, GP);
7593 ptr_table_store(PL_ptr_table, gp, ret);
7596 ret->gp_refcnt = 0; /* must be before any other dups! */
7597 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7598 ret->gp_io = io_dup_inc(gp->gp_io);
7599 ret->gp_form = cv_dup_inc(gp->gp_form);
7600 ret->gp_av = av_dup_inc(gp->gp_av);
7601 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7602 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7603 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7604 ret->gp_cvgen = gp->gp_cvgen;
7605 ret->gp_flags = gp->gp_flags;
7606 ret->gp_line = gp->gp_line;
7607 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7612 Perl_mg_dup(pTHX_ MAGIC *mg)
7614 MAGIC *mgret = (MAGIC*)NULL;
7617 return (MAGIC*)NULL;
7618 /* look for it in the table first */
7619 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7623 for (; mg; mg = mg->mg_moremagic) {
7625 Newz(0, nmg, 1, MAGIC);
7629 mgprev->mg_moremagic = nmg;
7630 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7631 nmg->mg_private = mg->mg_private;
7632 nmg->mg_type = mg->mg_type;
7633 nmg->mg_flags = mg->mg_flags;
7634 if (mg->mg_type == 'r') {
7635 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7638 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7639 ? sv_dup_inc(mg->mg_obj)
7640 : sv_dup(mg->mg_obj);
7642 nmg->mg_len = mg->mg_len;
7643 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7644 if (mg->mg_ptr && mg->mg_type != 'g') {
7645 if (mg->mg_len >= 0) {
7646 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7647 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7648 AMT *amtp = (AMT*)mg->mg_ptr;
7649 AMT *namtp = (AMT*)nmg->mg_ptr;
7651 for (i = 1; i < NofAMmeth; i++) {
7652 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7656 else if (mg->mg_len == HEf_SVKEY)
7657 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7665 Perl_ptr_table_new(pTHX)
7668 Newz(0, tbl, 1, PTR_TBL_t);
7671 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7676 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7678 PTR_TBL_ENT_t *tblent;
7679 UV hash = PTR2UV(sv);
7681 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7682 for (; tblent; tblent = tblent->next) {
7683 if (tblent->oldval == sv)
7684 return tblent->newval;
7690 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7692 PTR_TBL_ENT_t *tblent, **otblent;
7693 /* XXX this may be pessimal on platforms where pointers aren't good
7694 * hash values e.g. if they grow faster in the most significant
7696 UV hash = PTR2UV(oldv);
7700 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7701 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7702 if (tblent->oldval == oldv) {
7703 tblent->newval = newv;
7708 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7709 tblent->oldval = oldv;
7710 tblent->newval = newv;
7711 tblent->next = *otblent;
7714 if (i && tbl->tbl_items > tbl->tbl_max)
7715 ptr_table_split(tbl);
7719 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7721 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7722 UV oldsize = tbl->tbl_max + 1;
7723 UV newsize = oldsize * 2;
7726 Renew(ary, newsize, PTR_TBL_ENT_t*);
7727 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7728 tbl->tbl_max = --newsize;
7730 for (i=0; i < oldsize; i++, ary++) {
7731 PTR_TBL_ENT_t **curentp, **entp, *ent;
7734 curentp = ary + oldsize;
7735 for (entp = ary, ent = *ary; ent; ent = *entp) {
7736 if ((newsize & PTR2UV(ent->oldval)) != i) {
7738 ent->next = *curentp;
7749 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7751 register PTR_TBL_ENT_t **array;
7752 register PTR_TBL_ENT_t *entry;
7753 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7757 if (!tbl || !tbl->tbl_items) {
7761 array = tbl->tbl_ary;
7768 entry = entry->next;
7772 if (++riter > max) {
7775 entry = array[riter];
7783 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7788 ptr_table_clear(tbl);
7789 Safefree(tbl->tbl_ary);
7798 S_gv_share(pTHX_ SV *sstr)
7801 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7803 if (GvIO(gv) || GvFORM(gv)) {
7804 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
7806 else if (!GvCV(gv)) {
7810 /* CvPADLISTs cannot be shared */
7811 if (!CvXSUB(GvCV(gv))) {
7816 if (!GvSHARED(gv)) {
7818 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
7819 HvNAME(GvSTASH(gv)), GvNAME(gv));
7825 * write attempts will die with
7826 * "Modification of a read-only value attempted"
7832 SvREADONLY_on(GvSV(gv));
7839 SvREADONLY_on(GvAV(gv));
7846 SvREADONLY_on(GvAV(gv));
7849 return sstr; /* he_dup() will SvREFCNT_inc() */
7853 Perl_sv_dup(pTHX_ SV *sstr)
7857 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7859 /* look for it in the table first */
7860 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7864 /* create anew and remember what it is */
7866 ptr_table_store(PL_ptr_table, sstr, dstr);
7869 SvFLAGS(dstr) = SvFLAGS(sstr);
7870 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7871 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7874 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7875 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7876 PL_watch_pvx, SvPVX(sstr));
7879 switch (SvTYPE(sstr)) {
7884 SvANY(dstr) = new_XIV();
7885 SvIVX(dstr) = SvIVX(sstr);
7888 SvANY(dstr) = new_XNV();
7889 SvNVX(dstr) = SvNVX(sstr);
7892 SvANY(dstr) = new_XRV();
7893 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7896 SvANY(dstr) = new_XPV();
7897 SvCUR(dstr) = SvCUR(sstr);
7898 SvLEN(dstr) = SvLEN(sstr);
7900 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7901 else if (SvPVX(sstr) && SvLEN(sstr))
7902 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7904 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7907 SvANY(dstr) = new_XPVIV();
7908 SvCUR(dstr) = SvCUR(sstr);
7909 SvLEN(dstr) = SvLEN(sstr);
7910 SvIVX(dstr) = SvIVX(sstr);
7912 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7913 else if (SvPVX(sstr) && SvLEN(sstr))
7914 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7916 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7919 SvANY(dstr) = new_XPVNV();
7920 SvCUR(dstr) = SvCUR(sstr);
7921 SvLEN(dstr) = SvLEN(sstr);
7922 SvIVX(dstr) = SvIVX(sstr);
7923 SvNVX(dstr) = SvNVX(sstr);
7925 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7926 else if (SvPVX(sstr) && SvLEN(sstr))
7927 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7929 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7932 SvANY(dstr) = new_XPVMG();
7933 SvCUR(dstr) = SvCUR(sstr);
7934 SvLEN(dstr) = SvLEN(sstr);
7935 SvIVX(dstr) = SvIVX(sstr);
7936 SvNVX(dstr) = SvNVX(sstr);
7937 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7938 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7940 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7941 else if (SvPVX(sstr) && SvLEN(sstr))
7942 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7944 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7947 SvANY(dstr) = new_XPVBM();
7948 SvCUR(dstr) = SvCUR(sstr);
7949 SvLEN(dstr) = SvLEN(sstr);
7950 SvIVX(dstr) = SvIVX(sstr);
7951 SvNVX(dstr) = SvNVX(sstr);
7952 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7953 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7955 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7956 else if (SvPVX(sstr) && SvLEN(sstr))
7957 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7959 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7960 BmRARE(dstr) = BmRARE(sstr);
7961 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7962 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7965 SvANY(dstr) = new_XPVLV();
7966 SvCUR(dstr) = SvCUR(sstr);
7967 SvLEN(dstr) = SvLEN(sstr);
7968 SvIVX(dstr) = SvIVX(sstr);
7969 SvNVX(dstr) = SvNVX(sstr);
7970 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7971 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7973 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7974 else if (SvPVX(sstr) && SvLEN(sstr))
7975 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7977 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7978 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7979 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7980 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7981 LvTYPE(dstr) = LvTYPE(sstr);
7984 if (GvSHARED((GV*)sstr)) {
7986 if ((share = gv_share(sstr))) {
7990 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
7991 HvNAME(GvSTASH(share)), GvNAME(share));
7996 SvANY(dstr) = new_XPVGV();
7997 SvCUR(dstr) = SvCUR(sstr);
7998 SvLEN(dstr) = SvLEN(sstr);
7999 SvIVX(dstr) = SvIVX(sstr);
8000 SvNVX(dstr) = SvNVX(sstr);
8001 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8002 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8004 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8005 else if (SvPVX(sstr) && SvLEN(sstr))
8006 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8008 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8009 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8010 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8011 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8012 GvFLAGS(dstr) = GvFLAGS(sstr);
8013 GvGP(dstr) = gp_dup(GvGP(sstr));
8014 (void)GpREFCNT_inc(GvGP(dstr));
8017 SvANY(dstr) = new_XPVIO();
8018 SvCUR(dstr) = SvCUR(sstr);
8019 SvLEN(dstr) = SvLEN(sstr);
8020 SvIVX(dstr) = SvIVX(sstr);
8021 SvNVX(dstr) = SvNVX(sstr);
8022 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8023 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8025 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8026 else if (SvPVX(sstr) && SvLEN(sstr))
8027 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8029 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8030 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8031 if (IoOFP(sstr) == IoIFP(sstr))
8032 IoOFP(dstr) = IoIFP(dstr);
8034 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8035 /* PL_rsfp_filters entries have fake IoDIRP() */
8036 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8037 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8039 IoDIRP(dstr) = IoDIRP(sstr);
8040 IoLINES(dstr) = IoLINES(sstr);
8041 IoPAGE(dstr) = IoPAGE(sstr);
8042 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8043 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8044 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8045 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8046 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8047 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8048 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8049 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8050 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8051 IoTYPE(dstr) = IoTYPE(sstr);
8052 IoFLAGS(dstr) = IoFLAGS(sstr);
8055 SvANY(dstr) = new_XPVAV();
8056 SvCUR(dstr) = SvCUR(sstr);
8057 SvLEN(dstr) = SvLEN(sstr);
8058 SvIVX(dstr) = SvIVX(sstr);
8059 SvNVX(dstr) = SvNVX(sstr);
8060 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8061 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8062 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8063 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8064 if (AvARRAY((AV*)sstr)) {
8065 SV **dst_ary, **src_ary;
8066 SSize_t items = AvFILLp((AV*)sstr) + 1;
8068 src_ary = AvARRAY((AV*)sstr);
8069 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8070 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8071 SvPVX(dstr) = (char*)dst_ary;
8072 AvALLOC((AV*)dstr) = dst_ary;
8073 if (AvREAL((AV*)sstr)) {
8075 *dst_ary++ = sv_dup_inc(*src_ary++);
8079 *dst_ary++ = sv_dup(*src_ary++);
8081 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8082 while (items-- > 0) {
8083 *dst_ary++ = &PL_sv_undef;
8087 SvPVX(dstr) = Nullch;
8088 AvALLOC((AV*)dstr) = (SV**)NULL;
8092 SvANY(dstr) = new_XPVHV();
8093 SvCUR(dstr) = SvCUR(sstr);
8094 SvLEN(dstr) = SvLEN(sstr);
8095 SvIVX(dstr) = SvIVX(sstr);
8096 SvNVX(dstr) = SvNVX(sstr);
8097 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8098 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8099 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8100 if (HvARRAY((HV*)sstr)) {
8102 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8103 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8104 Newz(0, dxhv->xhv_array,
8105 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8106 while (i <= sxhv->xhv_max) {
8107 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8108 !!HvSHAREKEYS(sstr));
8111 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8114 SvPVX(dstr) = Nullch;
8115 HvEITER((HV*)dstr) = (HE*)NULL;
8117 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8118 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8121 SvANY(dstr) = new_XPVFM();
8122 FmLINES(dstr) = FmLINES(sstr);
8126 SvANY(dstr) = new_XPVCV();
8128 SvCUR(dstr) = SvCUR(sstr);
8129 SvLEN(dstr) = SvLEN(sstr);
8130 SvIVX(dstr) = SvIVX(sstr);
8131 SvNVX(dstr) = SvNVX(sstr);
8132 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8133 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8134 if (SvPVX(sstr) && SvLEN(sstr))
8135 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8137 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8138 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8139 CvSTART(dstr) = CvSTART(sstr);
8140 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8141 CvXSUB(dstr) = CvXSUB(sstr);
8142 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8143 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
8144 CvDEPTH(dstr) = CvDEPTH(sstr);
8145 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8146 /* XXX padlists are real, but pretend to be not */
8147 AvREAL_on(CvPADLIST(sstr));
8148 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8149 AvREAL_off(CvPADLIST(sstr));
8150 AvREAL_off(CvPADLIST(dstr));
8153 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8154 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8155 CvFLAGS(dstr) = CvFLAGS(sstr);
8158 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8162 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8169 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8174 return (PERL_CONTEXT*)NULL;
8176 /* look for it in the table first */
8177 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8181 /* create anew and remember what it is */
8182 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8183 ptr_table_store(PL_ptr_table, cxs, ncxs);
8186 PERL_CONTEXT *cx = &cxs[ix];
8187 PERL_CONTEXT *ncx = &ncxs[ix];
8188 ncx->cx_type = cx->cx_type;
8189 if (CxTYPE(cx) == CXt_SUBST) {
8190 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8193 ncx->blk_oldsp = cx->blk_oldsp;
8194 ncx->blk_oldcop = cx->blk_oldcop;
8195 ncx->blk_oldretsp = cx->blk_oldretsp;
8196 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8197 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8198 ncx->blk_oldpm = cx->blk_oldpm;
8199 ncx->blk_gimme = cx->blk_gimme;
8200 switch (CxTYPE(cx)) {
8202 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8203 ? cv_dup_inc(cx->blk_sub.cv)
8204 : cv_dup(cx->blk_sub.cv));
8205 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8206 ? av_dup_inc(cx->blk_sub.argarray)
8208 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
8209 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8210 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8211 ncx->blk_sub.lval = cx->blk_sub.lval;
8214 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8215 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8216 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8217 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8218 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8221 ncx->blk_loop.label = cx->blk_loop.label;
8222 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8223 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8224 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8225 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8226 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8227 ? cx->blk_loop.iterdata
8228 : gv_dup((GV*)cx->blk_loop.iterdata));
8229 ncx->blk_loop.oldcurpad
8230 = (SV**)ptr_table_fetch(PL_ptr_table,
8231 cx->blk_loop.oldcurpad);
8232 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8233 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8234 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8235 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8236 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8239 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8240 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8241 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8242 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8255 Perl_si_dup(pTHX_ PERL_SI *si)
8260 return (PERL_SI*)NULL;
8262 /* look for it in the table first */
8263 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8267 /* create anew and remember what it is */
8268 Newz(56, nsi, 1, PERL_SI);
8269 ptr_table_store(PL_ptr_table, si, nsi);
8271 nsi->si_stack = av_dup_inc(si->si_stack);
8272 nsi->si_cxix = si->si_cxix;
8273 nsi->si_cxmax = si->si_cxmax;
8274 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8275 nsi->si_type = si->si_type;
8276 nsi->si_prev = si_dup(si->si_prev);
8277 nsi->si_next = si_dup(si->si_next);
8278 nsi->si_markoff = si->si_markoff;
8283 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8284 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8285 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8286 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8287 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8288 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8289 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8290 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8291 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8292 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8293 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8294 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8297 #define pv_dup_inc(p) SAVEPV(p)
8298 #define pv_dup(p) SAVEPV(p)
8299 #define svp_dup_inc(p,pp) any_dup(p,pp)
8302 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8309 /* look for it in the table first */
8310 ret = ptr_table_fetch(PL_ptr_table, v);
8314 /* see if it is part of the interpreter structure */
8315 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8316 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8324 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8326 ANY *ss = proto_perl->Tsavestack;
8327 I32 ix = proto_perl->Tsavestack_ix;
8328 I32 max = proto_perl->Tsavestack_max;
8341 void (*dptr) (void*);
8342 void (*dxptr) (pTHXo_ void*);
8345 Newz(54, nss, max, ANY);
8351 case SAVEt_ITEM: /* normal string */
8352 sv = (SV*)POPPTR(ss,ix);
8353 TOPPTR(nss,ix) = sv_dup_inc(sv);
8354 sv = (SV*)POPPTR(ss,ix);
8355 TOPPTR(nss,ix) = sv_dup_inc(sv);
8357 case SAVEt_SV: /* scalar reference */
8358 sv = (SV*)POPPTR(ss,ix);
8359 TOPPTR(nss,ix) = sv_dup_inc(sv);
8360 gv = (GV*)POPPTR(ss,ix);
8361 TOPPTR(nss,ix) = gv_dup_inc(gv);
8363 case SAVEt_GENERIC_PVREF: /* generic char* */
8364 c = (char*)POPPTR(ss,ix);
8365 TOPPTR(nss,ix) = pv_dup(c);
8366 ptr = POPPTR(ss,ix);
8367 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8369 case SAVEt_GENERIC_SVREF: /* generic sv */
8370 case SAVEt_SVREF: /* scalar reference */
8371 sv = (SV*)POPPTR(ss,ix);
8372 TOPPTR(nss,ix) = sv_dup_inc(sv);
8373 ptr = POPPTR(ss,ix);
8374 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8376 case SAVEt_AV: /* array reference */
8377 av = (AV*)POPPTR(ss,ix);
8378 TOPPTR(nss,ix) = av_dup_inc(av);
8379 gv = (GV*)POPPTR(ss,ix);
8380 TOPPTR(nss,ix) = gv_dup(gv);
8382 case SAVEt_HV: /* hash reference */
8383 hv = (HV*)POPPTR(ss,ix);
8384 TOPPTR(nss,ix) = hv_dup_inc(hv);
8385 gv = (GV*)POPPTR(ss,ix);
8386 TOPPTR(nss,ix) = gv_dup(gv);
8388 case SAVEt_INT: /* int reference */
8389 ptr = POPPTR(ss,ix);
8390 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8391 intval = (int)POPINT(ss,ix);
8392 TOPINT(nss,ix) = intval;
8394 case SAVEt_LONG: /* long reference */
8395 ptr = POPPTR(ss,ix);
8396 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8397 longval = (long)POPLONG(ss,ix);
8398 TOPLONG(nss,ix) = longval;
8400 case SAVEt_I32: /* I32 reference */
8401 case SAVEt_I16: /* I16 reference */
8402 case SAVEt_I8: /* I8 reference */
8403 ptr = POPPTR(ss,ix);
8404 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8408 case SAVEt_IV: /* IV reference */
8409 ptr = POPPTR(ss,ix);
8410 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8414 case SAVEt_SPTR: /* SV* reference */
8415 ptr = POPPTR(ss,ix);
8416 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8417 sv = (SV*)POPPTR(ss,ix);
8418 TOPPTR(nss,ix) = sv_dup(sv);
8420 case SAVEt_VPTR: /* random* reference */
8421 ptr = POPPTR(ss,ix);
8422 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8423 ptr = POPPTR(ss,ix);
8424 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8426 case SAVEt_PPTR: /* char* reference */
8427 ptr = POPPTR(ss,ix);
8428 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8429 c = (char*)POPPTR(ss,ix);
8430 TOPPTR(nss,ix) = pv_dup(c);
8432 case SAVEt_HPTR: /* HV* reference */
8433 ptr = POPPTR(ss,ix);
8434 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8435 hv = (HV*)POPPTR(ss,ix);
8436 TOPPTR(nss,ix) = hv_dup(hv);
8438 case SAVEt_APTR: /* AV* reference */
8439 ptr = POPPTR(ss,ix);
8440 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8441 av = (AV*)POPPTR(ss,ix);
8442 TOPPTR(nss,ix) = av_dup(av);
8445 gv = (GV*)POPPTR(ss,ix);
8446 TOPPTR(nss,ix) = gv_dup(gv);
8448 case SAVEt_GP: /* scalar reference */
8449 gp = (GP*)POPPTR(ss,ix);
8450 TOPPTR(nss,ix) = gp = gp_dup(gp);
8451 (void)GpREFCNT_inc(gp);
8452 gv = (GV*)POPPTR(ss,ix);
8453 TOPPTR(nss,ix) = gv_dup_inc(c);
8454 c = (char*)POPPTR(ss,ix);
8455 TOPPTR(nss,ix) = pv_dup(c);
8462 sv = (SV*)POPPTR(ss,ix);
8463 TOPPTR(nss,ix) = sv_dup_inc(sv);
8466 ptr = POPPTR(ss,ix);
8467 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8468 /* these are assumed to be refcounted properly */
8469 switch (((OP*)ptr)->op_type) {
8476 TOPPTR(nss,ix) = ptr;
8481 TOPPTR(nss,ix) = Nullop;
8486 TOPPTR(nss,ix) = Nullop;
8489 c = (char*)POPPTR(ss,ix);
8490 TOPPTR(nss,ix) = pv_dup_inc(c);
8493 longval = POPLONG(ss,ix);
8494 TOPLONG(nss,ix) = longval;
8497 hv = (HV*)POPPTR(ss,ix);
8498 TOPPTR(nss,ix) = hv_dup_inc(hv);
8499 c = (char*)POPPTR(ss,ix);
8500 TOPPTR(nss,ix) = pv_dup_inc(c);
8504 case SAVEt_DESTRUCTOR:
8505 ptr = POPPTR(ss,ix);
8506 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8507 dptr = POPDPTR(ss,ix);
8508 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8510 case SAVEt_DESTRUCTOR_X:
8511 ptr = POPPTR(ss,ix);
8512 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8513 dxptr = POPDXPTR(ss,ix);
8514 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8516 case SAVEt_REGCONTEXT:
8522 case SAVEt_STACK_POS: /* Position on Perl stack */
8526 case SAVEt_AELEM: /* array element */
8527 sv = (SV*)POPPTR(ss,ix);
8528 TOPPTR(nss,ix) = sv_dup_inc(sv);
8531 av = (AV*)POPPTR(ss,ix);
8532 TOPPTR(nss,ix) = av_dup_inc(av);
8534 case SAVEt_HELEM: /* hash element */
8535 sv = (SV*)POPPTR(ss,ix);
8536 TOPPTR(nss,ix) = sv_dup_inc(sv);
8537 sv = (SV*)POPPTR(ss,ix);
8538 TOPPTR(nss,ix) = sv_dup_inc(sv);
8539 hv = (HV*)POPPTR(ss,ix);
8540 TOPPTR(nss,ix) = hv_dup_inc(hv);
8543 ptr = POPPTR(ss,ix);
8544 TOPPTR(nss,ix) = ptr;
8551 av = (AV*)POPPTR(ss,ix);
8552 TOPPTR(nss,ix) = av_dup(av);
8555 longval = (long)POPLONG(ss,ix);
8556 TOPLONG(nss,ix) = longval;
8557 ptr = POPPTR(ss,ix);
8558 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8559 sv = (SV*)POPPTR(ss,ix);
8560 TOPPTR(nss,ix) = sv_dup(sv);
8563 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8575 perl_clone(PerlInterpreter *proto_perl, UV flags)
8578 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8581 #ifdef PERL_IMPLICIT_SYS
8582 return perl_clone_using(proto_perl, flags,
8584 proto_perl->IMemShared,
8585 proto_perl->IMemParse,
8595 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8596 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8597 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8598 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8599 struct IPerlDir* ipD, struct IPerlSock* ipS,
8600 struct IPerlProc* ipP)
8602 /* XXX many of the string copies here can be optimized if they're
8603 * constants; they need to be allocated as common memory and just
8604 * their pointers copied. */
8608 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8610 PERL_SET_THX(pPerl);
8611 # else /* !PERL_OBJECT */
8612 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8613 PERL_SET_THX(my_perl);
8616 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8622 # else /* !DEBUGGING */
8623 Zero(my_perl, 1, PerlInterpreter);
8624 # endif /* DEBUGGING */
8628 PL_MemShared = ipMS;
8636 # endif /* PERL_OBJECT */
8637 #else /* !PERL_IMPLICIT_SYS */
8639 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8640 PERL_SET_THX(my_perl);
8643 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8649 # else /* !DEBUGGING */
8650 Zero(my_perl, 1, PerlInterpreter);
8651 # endif /* DEBUGGING */
8652 #endif /* PERL_IMPLICIT_SYS */
8655 PL_xiv_arenaroot = NULL;
8657 PL_xnv_arenaroot = NULL;
8659 PL_xrv_arenaroot = NULL;
8661 PL_xpv_arenaroot = NULL;
8663 PL_xpviv_arenaroot = NULL;
8664 PL_xpviv_root = NULL;
8665 PL_xpvnv_arenaroot = NULL;
8666 PL_xpvnv_root = NULL;
8667 PL_xpvcv_arenaroot = NULL;
8668 PL_xpvcv_root = NULL;
8669 PL_xpvav_arenaroot = NULL;
8670 PL_xpvav_root = NULL;
8671 PL_xpvhv_arenaroot = NULL;
8672 PL_xpvhv_root = NULL;
8673 PL_xpvmg_arenaroot = NULL;
8674 PL_xpvmg_root = NULL;
8675 PL_xpvlv_arenaroot = NULL;
8676 PL_xpvlv_root = NULL;
8677 PL_xpvbm_arenaroot = NULL;
8678 PL_xpvbm_root = NULL;
8679 PL_he_arenaroot = NULL;
8681 PL_nice_chunk = NULL;
8682 PL_nice_chunk_size = 0;
8685 PL_sv_root = Nullsv;
8686 PL_sv_arenaroot = Nullsv;
8688 PL_debug = proto_perl->Idebug;
8690 /* create SV map for pointer relocation */
8691 PL_ptr_table = ptr_table_new();
8693 /* initialize these special pointers as early as possible */
8694 SvANY(&PL_sv_undef) = NULL;
8695 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8696 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8697 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8700 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8702 SvANY(&PL_sv_no) = new_XPVNV();
8704 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8705 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8706 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8707 SvCUR(&PL_sv_no) = 0;
8708 SvLEN(&PL_sv_no) = 1;
8709 SvNVX(&PL_sv_no) = 0;
8710 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8713 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8715 SvANY(&PL_sv_yes) = new_XPVNV();
8717 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8718 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8719 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8720 SvCUR(&PL_sv_yes) = 1;
8721 SvLEN(&PL_sv_yes) = 2;
8722 SvNVX(&PL_sv_yes) = 1;
8723 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8725 /* create shared string table */
8726 PL_strtab = newHV();
8727 HvSHAREKEYS_off(PL_strtab);
8728 hv_ksplit(PL_strtab, 512);
8729 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8731 PL_compiling = proto_perl->Icompiling;
8732 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8733 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8734 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8735 if (!specialWARN(PL_compiling.cop_warnings))
8736 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8737 if (!specialCopIO(PL_compiling.cop_io))
8738 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8739 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8741 /* pseudo environmental stuff */
8742 PL_origargc = proto_perl->Iorigargc;
8744 New(0, PL_origargv, i+1, char*);
8745 PL_origargv[i] = '\0';
8747 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8749 PL_envgv = gv_dup(proto_perl->Ienvgv);
8750 PL_incgv = gv_dup(proto_perl->Iincgv);
8751 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8752 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8753 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8754 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8757 PL_minus_c = proto_perl->Iminus_c;
8758 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8759 PL_localpatches = proto_perl->Ilocalpatches;
8760 PL_splitstr = proto_perl->Isplitstr;
8761 PL_preprocess = proto_perl->Ipreprocess;
8762 PL_minus_n = proto_perl->Iminus_n;
8763 PL_minus_p = proto_perl->Iminus_p;
8764 PL_minus_l = proto_perl->Iminus_l;
8765 PL_minus_a = proto_perl->Iminus_a;
8766 PL_minus_F = proto_perl->Iminus_F;
8767 PL_doswitches = proto_perl->Idoswitches;
8768 PL_dowarn = proto_perl->Idowarn;
8769 PL_doextract = proto_perl->Idoextract;
8770 PL_sawampersand = proto_perl->Isawampersand;
8771 PL_unsafe = proto_perl->Iunsafe;
8772 PL_inplace = SAVEPV(proto_perl->Iinplace);
8773 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8774 PL_perldb = proto_perl->Iperldb;
8775 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8777 /* magical thingies */
8778 /* XXX time(&PL_basetime) when asked for? */
8779 PL_basetime = proto_perl->Ibasetime;
8780 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8782 PL_maxsysfd = proto_perl->Imaxsysfd;
8783 PL_multiline = proto_perl->Imultiline;
8784 PL_statusvalue = proto_perl->Istatusvalue;
8786 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8789 /* shortcuts to various I/O objects */
8790 PL_stdingv = gv_dup(proto_perl->Istdingv);
8791 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8792 PL_defgv = gv_dup(proto_perl->Idefgv);
8793 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8794 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8795 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8797 /* shortcuts to regexp stuff */
8798 PL_replgv = gv_dup(proto_perl->Ireplgv);
8800 /* shortcuts to misc objects */
8801 PL_errgv = gv_dup(proto_perl->Ierrgv);
8803 /* shortcuts to debugging objects */
8804 PL_DBgv = gv_dup(proto_perl->IDBgv);
8805 PL_DBline = gv_dup(proto_perl->IDBline);
8806 PL_DBsub = gv_dup(proto_perl->IDBsub);
8807 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8808 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8809 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8810 PL_lineary = av_dup(proto_perl->Ilineary);
8811 PL_dbargs = av_dup(proto_perl->Idbargs);
8814 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8815 PL_curstash = hv_dup(proto_perl->Tcurstash);
8816 PL_debstash = hv_dup(proto_perl->Idebstash);
8817 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8818 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8820 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8821 PL_endav = av_dup_inc(proto_perl->Iendav);
8822 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8823 PL_initav = av_dup_inc(proto_perl->Iinitav);
8825 PL_sub_generation = proto_perl->Isub_generation;
8827 /* funky return mechanisms */
8828 PL_forkprocess = proto_perl->Iforkprocess;
8830 /* subprocess state */
8831 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8833 /* internal state */
8834 PL_tainting = proto_perl->Itainting;
8835 PL_maxo = proto_perl->Imaxo;
8836 if (proto_perl->Iop_mask)
8837 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8839 PL_op_mask = Nullch;
8841 /* current interpreter roots */
8842 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8843 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8844 PL_main_start = proto_perl->Imain_start;
8845 PL_eval_root = proto_perl->Ieval_root;
8846 PL_eval_start = proto_perl->Ieval_start;
8848 /* runtime control stuff */
8849 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8850 PL_copline = proto_perl->Icopline;
8852 PL_filemode = proto_perl->Ifilemode;
8853 PL_lastfd = proto_perl->Ilastfd;
8854 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8857 PL_gensym = proto_perl->Igensym;
8858 PL_preambled = proto_perl->Ipreambled;
8859 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8860 PL_laststatval = proto_perl->Ilaststatval;
8861 PL_laststype = proto_perl->Ilaststype;
8862 PL_mess_sv = Nullsv;
8864 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8865 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8867 /* interpreter atexit processing */
8868 PL_exitlistlen = proto_perl->Iexitlistlen;
8869 if (PL_exitlistlen) {
8870 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8871 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8874 PL_exitlist = (PerlExitListEntry*)NULL;
8875 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8877 PL_profiledata = NULL;
8878 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8879 /* PL_rsfp_filters entries have fake IoDIRP() */
8880 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8882 PL_compcv = cv_dup(proto_perl->Icompcv);
8883 PL_comppad = av_dup(proto_perl->Icomppad);
8884 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8885 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8886 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8887 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8888 proto_perl->Tcurpad);
8890 #ifdef HAVE_INTERP_INTERN
8891 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8894 /* more statics moved here */
8895 PL_generation = proto_perl->Igeneration;
8896 PL_DBcv = cv_dup(proto_perl->IDBcv);
8898 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8899 PL_in_clean_all = proto_perl->Iin_clean_all;
8901 PL_uid = proto_perl->Iuid;
8902 PL_euid = proto_perl->Ieuid;
8903 PL_gid = proto_perl->Igid;
8904 PL_egid = proto_perl->Iegid;
8905 PL_nomemok = proto_perl->Inomemok;
8906 PL_an = proto_perl->Ian;
8907 PL_cop_seqmax = proto_perl->Icop_seqmax;
8908 PL_op_seqmax = proto_perl->Iop_seqmax;
8909 PL_evalseq = proto_perl->Ievalseq;
8910 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8911 PL_origalen = proto_perl->Iorigalen;
8912 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8913 PL_osname = SAVEPV(proto_perl->Iosname);
8914 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8915 PL_sighandlerp = proto_perl->Isighandlerp;
8918 PL_runops = proto_perl->Irunops;
8920 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8923 PL_cshlen = proto_perl->Icshlen;
8924 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8927 PL_lex_state = proto_perl->Ilex_state;
8928 PL_lex_defer = proto_perl->Ilex_defer;
8929 PL_lex_expect = proto_perl->Ilex_expect;
8930 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8931 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8932 PL_lex_starts = proto_perl->Ilex_starts;
8933 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8934 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8935 PL_lex_op = proto_perl->Ilex_op;
8936 PL_lex_inpat = proto_perl->Ilex_inpat;
8937 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8938 PL_lex_brackets = proto_perl->Ilex_brackets;
8939 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8940 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8941 PL_lex_casemods = proto_perl->Ilex_casemods;
8942 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8943 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8945 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8946 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8947 PL_nexttoke = proto_perl->Inexttoke;
8949 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8950 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8951 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8952 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8953 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8954 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8955 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8956 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8957 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8958 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8959 PL_pending_ident = proto_perl->Ipending_ident;
8960 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8962 PL_expect = proto_perl->Iexpect;
8964 PL_multi_start = proto_perl->Imulti_start;
8965 PL_multi_end = proto_perl->Imulti_end;
8966 PL_multi_open = proto_perl->Imulti_open;
8967 PL_multi_close = proto_perl->Imulti_close;
8969 PL_error_count = proto_perl->Ierror_count;
8970 PL_subline = proto_perl->Isubline;
8971 PL_subname = sv_dup_inc(proto_perl->Isubname);
8973 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8974 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8975 PL_padix = proto_perl->Ipadix;
8976 PL_padix_floor = proto_perl->Ipadix_floor;
8977 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8979 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8980 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8981 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8982 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8983 PL_last_lop_op = proto_perl->Ilast_lop_op;
8984 PL_in_my = proto_perl->Iin_my;
8985 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8987 PL_cryptseen = proto_perl->Icryptseen;
8990 PL_hints = proto_perl->Ihints;
8992 PL_amagic_generation = proto_perl->Iamagic_generation;
8994 #ifdef USE_LOCALE_COLLATE
8995 PL_collation_ix = proto_perl->Icollation_ix;
8996 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8997 PL_collation_standard = proto_perl->Icollation_standard;
8998 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8999 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9000 #endif /* USE_LOCALE_COLLATE */
9002 #ifdef USE_LOCALE_NUMERIC
9003 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9004 PL_numeric_standard = proto_perl->Inumeric_standard;
9005 PL_numeric_local = proto_perl->Inumeric_local;
9006 PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix);
9007 #endif /* !USE_LOCALE_NUMERIC */
9009 /* utf8 character classes */
9010 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9011 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9012 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9013 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9014 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9015 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9016 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9017 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9018 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9019 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9020 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9021 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9022 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9023 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9024 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9025 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9026 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9029 PL_last_swash_hv = Nullhv; /* reinits on demand */
9030 PL_last_swash_klen = 0;
9031 PL_last_swash_key[0]= '\0';
9032 PL_last_swash_tmps = (U8*)NULL;
9033 PL_last_swash_slen = 0;
9035 /* perly.c globals */
9036 PL_yydebug = proto_perl->Iyydebug;
9037 PL_yynerrs = proto_perl->Iyynerrs;
9038 PL_yyerrflag = proto_perl->Iyyerrflag;
9039 PL_yychar = proto_perl->Iyychar;
9040 PL_yyval = proto_perl->Iyyval;
9041 PL_yylval = proto_perl->Iyylval;
9043 PL_glob_index = proto_perl->Iglob_index;
9044 PL_srand_called = proto_perl->Isrand_called;
9045 PL_uudmap['M'] = 0; /* reinits on demand */
9046 PL_bitcount = Nullch; /* reinits on demand */
9048 if (proto_perl->Ipsig_pend) {
9049 Newz(0, PL_psig_pend, SIG_SIZE, int);
9052 PL_psig_pend = (int*)NULL;
9055 if (proto_perl->Ipsig_ptr) {
9056 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9057 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9058 for (i = 1; i < SIG_SIZE; i++) {
9059 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9060 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9064 PL_psig_ptr = (SV**)NULL;
9065 PL_psig_name = (SV**)NULL;
9068 /* thrdvar.h stuff */
9070 if (flags & CLONEf_COPY_STACKS) {
9071 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9072 PL_tmps_ix = proto_perl->Ttmps_ix;
9073 PL_tmps_max = proto_perl->Ttmps_max;
9074 PL_tmps_floor = proto_perl->Ttmps_floor;
9075 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9077 while (i <= PL_tmps_ix) {
9078 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9082 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9083 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9084 Newz(54, PL_markstack, i, I32);
9085 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9086 - proto_perl->Tmarkstack);
9087 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9088 - proto_perl->Tmarkstack);
9089 Copy(proto_perl->Tmarkstack, PL_markstack,
9090 PL_markstack_ptr - PL_markstack + 1, I32);
9092 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9093 * NOTE: unlike the others! */
9094 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9095 PL_scopestack_max = proto_perl->Tscopestack_max;
9096 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9097 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9099 /* next push_return() sets PL_retstack[PL_retstack_ix]
9100 * NOTE: unlike the others! */
9101 PL_retstack_ix = proto_perl->Tretstack_ix;
9102 PL_retstack_max = proto_perl->Tretstack_max;
9103 Newz(54, PL_retstack, PL_retstack_max, OP*);
9104 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9106 /* NOTE: si_dup() looks at PL_markstack */
9107 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9109 /* PL_curstack = PL_curstackinfo->si_stack; */
9110 PL_curstack = av_dup(proto_perl->Tcurstack);
9111 PL_mainstack = av_dup(proto_perl->Tmainstack);
9113 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9114 PL_stack_base = AvARRAY(PL_curstack);
9115 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9116 - proto_perl->Tstack_base);
9117 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9119 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9120 * NOTE: unlike the others! */
9121 PL_savestack_ix = proto_perl->Tsavestack_ix;
9122 PL_savestack_max = proto_perl->Tsavestack_max;
9123 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9124 PL_savestack = ss_dup(proto_perl);
9128 ENTER; /* perl_destruct() wants to LEAVE; */
9131 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9132 PL_top_env = &PL_start_env;
9134 PL_op = proto_perl->Top;
9137 PL_Xpv = (XPV*)NULL;
9138 PL_na = proto_perl->Tna;
9140 PL_statbuf = proto_perl->Tstatbuf;
9141 PL_statcache = proto_perl->Tstatcache;
9142 PL_statgv = gv_dup(proto_perl->Tstatgv);
9143 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9145 PL_timesbuf = proto_perl->Ttimesbuf;
9148 PL_tainted = proto_perl->Ttainted;
9149 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9150 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9151 PL_rs = sv_dup_inc(proto_perl->Trs);
9152 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9153 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9154 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9155 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9156 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9157 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9158 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9160 PL_restartop = proto_perl->Trestartop;
9161 PL_in_eval = proto_perl->Tin_eval;
9162 PL_delaymagic = proto_perl->Tdelaymagic;
9163 PL_dirty = proto_perl->Tdirty;
9164 PL_localizing = proto_perl->Tlocalizing;
9166 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9167 PL_protect = proto_perl->Tprotect;
9169 PL_errors = sv_dup_inc(proto_perl->Terrors);
9170 PL_av_fetch_sv = Nullsv;
9171 PL_hv_fetch_sv = Nullsv;
9172 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9173 PL_modcount = proto_perl->Tmodcount;
9174 PL_lastgotoprobe = Nullop;
9175 PL_dumpindent = proto_perl->Tdumpindent;
9177 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9178 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9179 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9180 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9181 PL_sortcxix = proto_perl->Tsortcxix;
9182 PL_efloatbuf = Nullch; /* reinits on demand */
9183 PL_efloatsize = 0; /* reinits on demand */
9187 PL_screamfirst = NULL;
9188 PL_screamnext = NULL;
9189 PL_maxscream = -1; /* reinits on demand */
9190 PL_lastscream = Nullsv;
9192 PL_watchaddr = NULL;
9193 PL_watchok = Nullch;
9195 PL_regdummy = proto_perl->Tregdummy;
9196 PL_regcomp_parse = Nullch;
9197 PL_regxend = Nullch;
9198 PL_regcode = (regnode*)NULL;
9201 PL_regprecomp = Nullch;
9206 PL_seen_zerolen = 0;
9208 PL_regcomp_rx = (regexp*)NULL;
9210 PL_colorset = 0; /* reinits PL_colors[] */
9211 /*PL_colors[6] = {0,0,0,0,0,0};*/
9212 PL_reg_whilem_seen = 0;
9213 PL_reginput = Nullch;
9216 PL_regstartp = (I32*)NULL;
9217 PL_regendp = (I32*)NULL;
9218 PL_reglastparen = (U32*)NULL;
9219 PL_regtill = Nullch;
9221 PL_reg_start_tmp = (char**)NULL;
9222 PL_reg_start_tmpl = 0;
9223 PL_regdata = (struct reg_data*)NULL;
9226 PL_reg_eval_set = 0;
9228 PL_regprogram = (regnode*)NULL;
9230 PL_regcc = (CURCUR*)NULL;
9231 PL_reg_call_cc = (struct re_cc_state*)NULL;
9232 PL_reg_re = (regexp*)NULL;
9233 PL_reg_ganch = Nullch;
9235 PL_reg_magic = (MAGIC*)NULL;
9237 PL_reg_oldcurpm = (PMOP*)NULL;
9238 PL_reg_curpm = (PMOP*)NULL;
9239 PL_reg_oldsaved = Nullch;
9240 PL_reg_oldsavedlen = 0;
9242 PL_reg_leftiter = 0;
9243 PL_reg_poscache = Nullch;
9244 PL_reg_poscache_size= 0;
9246 /* RE engine - function pointers */
9247 PL_regcompp = proto_perl->Tregcompp;
9248 PL_regexecp = proto_perl->Tregexecp;
9249 PL_regint_start = proto_perl->Tregint_start;
9250 PL_regint_string = proto_perl->Tregint_string;
9251 PL_regfree = proto_perl->Tregfree;
9253 PL_reginterp_cnt = 0;
9254 PL_reg_starttry = 0;
9256 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9257 ptr_table_free(PL_ptr_table);
9258 PL_ptr_table = NULL;
9262 return (PerlInterpreter*)pPerl;
9268 #else /* !USE_ITHREADS */
9274 #endif /* USE_ITHREADS */
9277 do_report_used(pTHXo_ SV *sv)
9279 if (SvTYPE(sv) != SVTYPEMASK) {
9280 PerlIO_printf(Perl_debug_log, "****\n");
9286 do_clean_objs(pTHXo_ SV *sv)
9290 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9291 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9292 if (SvWEAKREF(sv)) {
9303 /* XXX Might want to check arrays, etc. */
9306 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9308 do_clean_named_objs(pTHXo_ SV *sv)
9310 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9311 if ( SvOBJECT(GvSV(sv)) ||
9312 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9313 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9314 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9315 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9317 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9325 do_clean_all(pTHXo_ SV *sv)
9327 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9328 SvFLAGS(sv) |= SVf_BREAK;