3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
29 * "A time to plant, and a time to uproot what was planted..."
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
40 /* sv_mutex must be held while calling uproot_SV() */
41 #define uproot_SV(p) \
44 PL_sv_root = (SV*)SvANY(p); \
66 if (PL_debug & 32768) \
76 if (PL_debug & 32768) {
81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
83 svend = &sva[SvREFCNT(sva)];
84 if (p >= sv && p < svend)
88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
90 "Attempt to free non-arena SV: 0x%"UVxf,
98 #else /* ! DEBUGGING */
100 #define del_SV(p) plant_SV(p)
102 #endif /* DEBUGGING */
105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
110 Zero(ptr, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
197 XPV *arena, *arenanext;
199 /* Free arenas here, but be careful about fake ones. (We assume
200 contiguity of the fake ones with the corresponding real ones.) */
202 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
203 svanext = (SV*) SvANY(sva);
204 while (svanext && SvFAKE(svanext))
205 svanext = (SV*) SvANY(svanext);
208 Safefree((void *)sva);
211 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
212 arenanext = (XPV*)arena->xpv_pv;
215 PL_xiv_arenaroot = 0;
217 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
218 arenanext = (XPV*)arena->xpv_pv;
221 PL_xnv_arenaroot = 0;
223 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
224 arenanext = (XPV*)arena->xpv_pv;
227 PL_xrv_arenaroot = 0;
229 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
230 arenanext = (XPV*)arena->xpv_pv;
233 PL_xpv_arenaroot = 0;
235 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
236 arenanext = (XPV*)arena->xpv_pv;
239 PL_xpviv_arenaroot = 0;
241 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
242 arenanext = (XPV*)arena->xpv_pv;
245 PL_xpvnv_arenaroot = 0;
247 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
248 arenanext = (XPV*)arena->xpv_pv;
251 PL_xpvcv_arenaroot = 0;
253 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
254 arenanext = (XPV*)arena->xpv_pv;
257 PL_xpvav_arenaroot = 0;
259 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
260 arenanext = (XPV*)arena->xpv_pv;
263 PL_xpvhv_arenaroot = 0;
265 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
266 arenanext = (XPV*)arena->xpv_pv;
269 PL_xpvmg_arenaroot = 0;
271 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
272 arenanext = (XPV*)arena->xpv_pv;
275 PL_xpvlv_arenaroot = 0;
277 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
278 arenanext = (XPV*)arena->xpv_pv;
281 PL_xpvbm_arenaroot = 0;
283 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
284 arenanext = (XPV*)arena->xpv_pv;
290 Safefree(PL_nice_chunk);
291 PL_nice_chunk = Nullch;
292 PL_nice_chunk_size = 0;
298 Perl_report_uninit(pTHX)
301 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
302 " in ", PL_op_desc[PL_op->op_type]);
304 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
316 * See comment in more_xiv() -- RAM.
318 PL_xiv_root = *(IV**)xiv;
320 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
324 S_del_xiv(pTHX_ XPVIV *p)
326 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
328 *(IV**)xiv = PL_xiv_root;
339 New(705, ptr, 1008/sizeof(XPV), XPV);
340 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
341 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
344 xivend = &xiv[1008 / sizeof(IV) - 1];
345 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
347 while (xiv < xivend) {
348 *(IV**)xiv = (IV *)(xiv + 1);
362 PL_xnv_root = *(NV**)xnv;
364 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
368 S_del_xnv(pTHX_ XPVNV *p)
370 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
372 *(NV**)xnv = PL_xnv_root;
383 New(711, ptr, 1008/sizeof(XPV), XPV);
384 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
385 PL_xnv_arenaroot = ptr;
388 xnvend = &xnv[1008 / sizeof(NV) - 1];
389 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
391 while (xnv < xnvend) {
392 *(NV**)xnv = (NV*)(xnv + 1);
406 PL_xrv_root = (XRV*)xrv->xrv_rv;
412 S_del_xrv(pTHX_ XRV *p)
415 p->xrv_rv = (SV*)PL_xrv_root;
424 register XRV* xrvend;
426 New(712, ptr, 1008/sizeof(XPV), XPV);
427 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
428 PL_xrv_arenaroot = ptr;
431 xrvend = &xrv[1008 / sizeof(XRV) - 1];
432 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
434 while (xrv < xrvend) {
435 xrv->xrv_rv = (SV*)(xrv + 1);
449 PL_xpv_root = (XPV*)xpv->xpv_pv;
455 S_del_xpv(pTHX_ XPV *p)
458 p->xpv_pv = (char*)PL_xpv_root;
467 register XPV* xpvend;
468 New(713, xpv, 1008/sizeof(XPV), XPV);
469 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
470 PL_xpv_arenaroot = xpv;
472 xpvend = &xpv[1008 / sizeof(XPV) - 1];
474 while (xpv < xpvend) {
475 xpv->xpv_pv = (char*)(xpv + 1);
488 xpviv = PL_xpviv_root;
489 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
495 S_del_xpviv(pTHX_ XPVIV *p)
498 p->xpv_pv = (char*)PL_xpviv_root;
506 register XPVIV* xpviv;
507 register XPVIV* xpvivend;
508 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
509 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
510 PL_xpviv_arenaroot = xpviv;
512 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
513 PL_xpviv_root = ++xpviv;
514 while (xpviv < xpvivend) {
515 xpviv->xpv_pv = (char*)(xpviv + 1);
528 xpvnv = PL_xpvnv_root;
529 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
535 S_del_xpvnv(pTHX_ XPVNV *p)
538 p->xpv_pv = (char*)PL_xpvnv_root;
546 register XPVNV* xpvnv;
547 register XPVNV* xpvnvend;
548 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
549 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
550 PL_xpvnv_arenaroot = xpvnv;
552 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
553 PL_xpvnv_root = ++xpvnv;
554 while (xpvnv < xpvnvend) {
555 xpvnv->xpv_pv = (char*)(xpvnv + 1);
568 xpvcv = PL_xpvcv_root;
569 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
575 S_del_xpvcv(pTHX_ XPVCV *p)
578 p->xpv_pv = (char*)PL_xpvcv_root;
586 register XPVCV* xpvcv;
587 register XPVCV* xpvcvend;
588 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
589 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
590 PL_xpvcv_arenaroot = xpvcv;
592 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
593 PL_xpvcv_root = ++xpvcv;
594 while (xpvcv < xpvcvend) {
595 xpvcv->xpv_pv = (char*)(xpvcv + 1);
608 xpvav = PL_xpvav_root;
609 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
615 S_del_xpvav(pTHX_ XPVAV *p)
618 p->xav_array = (char*)PL_xpvav_root;
626 register XPVAV* xpvav;
627 register XPVAV* xpvavend;
628 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
629 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
630 PL_xpvav_arenaroot = xpvav;
632 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
633 PL_xpvav_root = ++xpvav;
634 while (xpvav < xpvavend) {
635 xpvav->xav_array = (char*)(xpvav + 1);
638 xpvav->xav_array = 0;
648 xpvhv = PL_xpvhv_root;
649 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
655 S_del_xpvhv(pTHX_ XPVHV *p)
658 p->xhv_array = (char*)PL_xpvhv_root;
666 register XPVHV* xpvhv;
667 register XPVHV* xpvhvend;
668 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
669 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
670 PL_xpvhv_arenaroot = xpvhv;
672 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
673 PL_xpvhv_root = ++xpvhv;
674 while (xpvhv < xpvhvend) {
675 xpvhv->xhv_array = (char*)(xpvhv + 1);
678 xpvhv->xhv_array = 0;
688 xpvmg = PL_xpvmg_root;
689 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
695 S_del_xpvmg(pTHX_ XPVMG *p)
698 p->xpv_pv = (char*)PL_xpvmg_root;
706 register XPVMG* xpvmg;
707 register XPVMG* xpvmgend;
708 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
709 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
710 PL_xpvmg_arenaroot = xpvmg;
712 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
713 PL_xpvmg_root = ++xpvmg;
714 while (xpvmg < xpvmgend) {
715 xpvmg->xpv_pv = (char*)(xpvmg + 1);
728 xpvlv = PL_xpvlv_root;
729 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
735 S_del_xpvlv(pTHX_ XPVLV *p)
738 p->xpv_pv = (char*)PL_xpvlv_root;
746 register XPVLV* xpvlv;
747 register XPVLV* xpvlvend;
748 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
749 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
750 PL_xpvlv_arenaroot = xpvlv;
752 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
753 PL_xpvlv_root = ++xpvlv;
754 while (xpvlv < xpvlvend) {
755 xpvlv->xpv_pv = (char*)(xpvlv + 1);
768 xpvbm = PL_xpvbm_root;
769 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
775 S_del_xpvbm(pTHX_ XPVBM *p)
778 p->xpv_pv = (char*)PL_xpvbm_root;
786 register XPVBM* xpvbm;
787 register XPVBM* xpvbmend;
788 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
789 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
790 PL_xpvbm_arenaroot = xpvbm;
792 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
793 PL_xpvbm_root = ++xpvbm;
794 while (xpvbm < xpvbmend) {
795 xpvbm->xpv_pv = (char*)(xpvbm + 1);
802 # define my_safemalloc(s) (void*)safexmalloc(717,s)
803 # define my_safefree(p) safexfree((char*)p)
805 # define my_safemalloc(s) (void*)safemalloc(s)
806 # define my_safefree(p) safefree((char*)p)
811 #define new_XIV() my_safemalloc(sizeof(XPVIV))
812 #define del_XIV(p) my_safefree(p)
814 #define new_XNV() my_safemalloc(sizeof(XPVNV))
815 #define del_XNV(p) my_safefree(p)
817 #define new_XRV() my_safemalloc(sizeof(XRV))
818 #define del_XRV(p) my_safefree(p)
820 #define new_XPV() my_safemalloc(sizeof(XPV))
821 #define del_XPV(p) my_safefree(p)
823 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
824 #define del_XPVIV(p) my_safefree(p)
826 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
827 #define del_XPVNV(p) my_safefree(p)
829 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
830 #define del_XPVCV(p) my_safefree(p)
832 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
833 #define del_XPVAV(p) my_safefree(p)
835 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
836 #define del_XPVHV(p) my_safefree(p)
838 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
839 #define del_XPVMG(p) my_safefree(p)
841 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
842 #define del_XPVLV(p) my_safefree(p)
844 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
845 #define del_XPVBM(p) my_safefree(p)
849 #define new_XIV() (void*)new_xiv()
850 #define del_XIV(p) del_xiv((XPVIV*) p)
852 #define new_XNV() (void*)new_xnv()
853 #define del_XNV(p) del_xnv((XPVNV*) p)
855 #define new_XRV() (void*)new_xrv()
856 #define del_XRV(p) del_xrv((XRV*) p)
858 #define new_XPV() (void*)new_xpv()
859 #define del_XPV(p) del_xpv((XPV *)p)
861 #define new_XPVIV() (void*)new_xpviv()
862 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
864 #define new_XPVNV() (void*)new_xpvnv()
865 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
867 #define new_XPVCV() (void*)new_xpvcv()
868 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
870 #define new_XPVAV() (void*)new_xpvav()
871 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
873 #define new_XPVHV() (void*)new_xpvhv()
874 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
876 #define new_XPVMG() (void*)new_xpvmg()
877 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
879 #define new_XPVLV() (void*)new_xpvlv()
880 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
882 #define new_XPVBM() (void*)new_xpvbm()
883 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
887 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
888 #define del_XPVGV(p) my_safefree(p)
890 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
891 #define del_XPVFM(p) my_safefree(p)
893 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
894 #define del_XPVIO(p) my_safefree(p)
897 =for apidoc sv_upgrade
899 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
906 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
916 if (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 if (u <= (UV)IV_MAX) {
1324 sv_setiv(sv, (IV)u);
1333 =for apidoc sv_setuv_mg
1335 Like C<sv_setuv>, but also handles 'set' magic.
1341 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1343 if (u <= (UV)IV_MAX) {
1344 sv_setiv(sv, (IV)u);
1354 =for apidoc sv_setnv
1356 Copies a double into the given SV. Does not handle 'set' magic. See
1363 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1365 SV_CHECK_THINKFIRST(sv);
1366 switch (SvTYPE(sv)) {
1369 sv_upgrade(sv, SVt_NV);
1374 sv_upgrade(sv, SVt_PVNV);
1383 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1384 PL_op_name[PL_op->op_type]);
1387 (void)SvNOK_only(sv); /* validate number */
1392 =for apidoc sv_setnv_mg
1394 Like C<sv_setnv>, but also handles 'set' magic.
1400 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1407 S_not_a_number(pTHX_ SV *sv)
1412 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1413 /* each *s can expand to 4 chars + "...\0",
1414 i.e. need room for 8 chars */
1416 for (s = SvPVX(sv); *s && d < limit; s++) {
1418 if (ch & 128 && !isPRINT_LC(ch)) {
1427 else if (ch == '\r') {
1431 else if (ch == '\f') {
1435 else if (ch == '\\') {
1439 else if (isPRINT_LC(ch))
1454 Perl_warner(aTHX_ WARN_NUMERIC,
1455 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1456 PL_op_desc[PL_op->op_type]);
1458 Perl_warner(aTHX_ WARN_NUMERIC,
1459 "Argument \"%s\" isn't numeric", tmpbuf);
1462 /* the number can be converted to integer with atol() or atoll() although */
1463 #define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
1464 #define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
1465 #define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
1466 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1467 #define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
1468 #define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
1469 #define IS_NUMBER_NEG 0x40 /* seen a leading - */
1470 #define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
1472 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1473 until proven guilty, assume that things are not that bad... */
1475 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1476 an IV (an assumption perl has been based on to date) it becomes necessary
1477 to remove the assumption that the NV always carries enough precision to
1478 recreate the IV whenever needed, and that the NV is the canonical form.
1479 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1480 precision as an side effect of conversion (which would lead to insanity
1481 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1482 1) to distinguish between IV/UV/NV slots that have cached a valid
1483 conversion where precision was lost and IV/UV/NV slots that have a
1484 valid conversion which has lost no precision
1485 2) to ensure that if a numeric conversion to one form is request that
1486 would lose precision, the precise conversion (or differently
1487 imprecise conversion) is also performed and cached, to prevent
1488 requests for different numeric formats on the same SV causing
1489 lossy conversion chains. (lossless conversion chains are perfectly
1494 SvIOKp is true if the IV slot contains a valid value
1495 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1496 SvNOKp is true if the NV slot contains a valid value
1497 SvNOK is true only if the NV value is accurate
1500 while converting from PV to NV check to see if converting that NV to an
1501 IV(or UV) would lose accuracy over a direct conversion from PV to
1502 IV(or UV). If it would, cache both conversions, return NV, but mark
1503 SV as IOK NOKp (ie not NOK).
1505 while converting from PV to IV check to see if converting that IV to an
1506 NV would lose accuracy over a direct conversion from PV to NV. If it
1507 would, cache both conversions, flag similarly.
1509 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1510 correctly because if IV & NV were set NV *always* overruled.
1511 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1512 changes - now IV and NV together means that the two are interchangeable
1513 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1515 The benefit of this is operations such as pp_add know that if SvIOK is
1516 true for both left and right operands, then integer addition can be
1517 used instead of floating point. (for cases where the result won't
1518 overflow) Before, floating point was always used, which could lead to
1519 loss of precision compared with integer addition.
1521 * making IV and NV equal status should make maths accurate on 64 bit
1523 * may speed up maths somewhat if pp_add and friends start to use
1524 integers when possible instead of fp. (hopefully the overhead in
1525 looking for SvIOK and checking for overflow will not outweigh the
1526 fp to integer speedup)
1527 * will slow down integer operations (callers of SvIV) on "inaccurate"
1528 values, as the change from SvIOK to SvIOKp will cause a call into
1529 sv_2iv each time rather than a macro access direct to the IV slot
1530 * should speed up number->string conversion on integers as IV is
1531 favoured when IV and NV equally accurate
1533 ####################################################################
1534 You had better be using SvIOK_notUV if you want an IV for arithmetic
1535 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1536 SvUOK is true iff UV.
1537 ####################################################################
1539 Your mileage will vary depending your CPUs relative fp to integer
1543 #ifndef NV_PRESERVES_UV
1544 #define IS_NUMBER_UNDERFLOW_IV 1
1545 #define IS_NUMBER_UNDERFLOW_UV 2
1546 #define IS_NUMBER_IV_AND_UV 2
1547 #define IS_NUMBER_OVERFLOW_IV 4
1548 #define IS_NUMBER_OVERFLOW_UV 5
1549 /* Hopefully your optimiser will consider inlining these two functions. */
1551 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1552 NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
1553 UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
1554 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype));
1555 if (nv_as_uv <= (UV)IV_MAX) {
1556 (void)SvIOKp_on(sv);
1557 (void)SvNOKp_on(sv);
1558 /* Within suitable range to fit in an IV, atol won't overflow */
1559 /* XXX quite sure? Is that your final answer? not really, I'm
1560 trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1561 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1562 if (numtype & IS_NUMBER_NOT_INT) {
1563 /* I believe that even if the original PV had decimals, they
1564 are lost beyond the limit of the FP precision.
1565 However, neither is canonical, so both only get p flags.
1567 /* Both already have p flags, so do nothing */
1568 } else if (SvIVX(sv) == I_V(nv)) {
1573 /* It had no "." so it must be integer. assert (get in here from
1574 sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1575 IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1576 conversion routines need audit. */
1578 return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1580 /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1581 (void)SvIOKp_on(sv);
1582 (void)SvNOKp_on(sv);
1585 int save_errno = errno;
1587 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1589 if (numtype & IS_NUMBER_NOT_INT) {
1590 /* UV and NV both imprecise. */
1592 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1601 return IS_NUMBER_OVERFLOW_IV;
1605 /* Must have just overflowed UV, but not enough that an NV could spot
1607 return IS_NUMBER_OVERFLOW_UV;
1610 /* We've just lost integer precision, nothing we could do. */
1611 SvUVX(sv) = nv_as_uv;
1612 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype));
1613 /* UV and NV slots equally valid only if we have casting symmetry. */
1614 if (numtype & IS_NUMBER_NOT_INT) {
1616 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1617 /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1618 UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1619 get to this point if NVs don't preserve UVs) */
1624 /* As above, I believe UV at least as good as NV */
1627 #endif /* HAS_STRTOUL */
1628 return IS_NUMBER_OVERFLOW_IV;
1631 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1633 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1635 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype));
1636 if (SvNVX(sv) < (NV)IV_MIN) {
1637 (void)SvIOKp_on(sv);
1640 return IS_NUMBER_UNDERFLOW_IV;
1642 if (SvNVX(sv) > (NV)UV_MAX) {
1643 (void)SvIOKp_on(sv);
1647 return IS_NUMBER_OVERFLOW_UV;
1649 if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1650 (void)SvIOKp_on(sv);
1652 /* Can't use strtol etc to convert this string */
1653 if (SvNVX(sv) <= (UV)IV_MAX) {
1654 SvIVX(sv) = I_V(SvNVX(sv));
1655 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1656 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1658 /* Integer is imprecise. NOK, IOKp */
1660 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1663 SvUVX(sv) = U_V(SvNVX(sv));
1664 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1665 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1667 /* Integer is imprecise. NOK, IOKp */
1669 return IS_NUMBER_OVERFLOW_IV;
1671 return S_sv_2inuv_non_preserve (sv, numtype);
1673 #endif /* NV_PRESERVES_UV*/
1677 Perl_sv_2iv(pTHX_ register SV *sv)
1681 if (SvGMAGICAL(sv)) {
1686 return I_V(SvNVX(sv));
1688 if (SvPOKp(sv) && SvLEN(sv))
1691 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1692 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1698 if (SvTHINKFIRST(sv)) {
1701 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1702 (SvRV(tmpstr) != SvRV(sv)))
1703 return SvIV(tmpstr);
1704 return PTR2IV(SvRV(sv));
1706 if (SvREADONLY(sv) && SvFAKE(sv)) {
1707 sv_force_normal(sv);
1709 if (SvREADONLY(sv) && !SvOK(sv)) {
1710 if (ckWARN(WARN_UNINITIALIZED))
1717 return (IV)(SvUVX(sv));
1724 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1725 * without also getting a cached IV/UV from it at the same time
1726 * (ie PV->NV conversion should detect loss of accuracy and cache
1727 * IV or UV at same time to avoid this. NWC */
1729 if (SvTYPE(sv) == SVt_NV)
1730 sv_upgrade(sv, SVt_PVNV);
1732 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1733 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1734 certainly cast into the IV range at IV_MAX, whereas the correct
1735 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1737 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1738 SvIVX(sv) = I_V(SvNVX(sv));
1739 if (SvNVX(sv) == (NV) SvIVX(sv)
1740 #ifndef NV_PRESERVES_UV
1741 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1742 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1743 /* Don't flag it as "accurately an integer" if the number
1744 came from a (by definition imprecise) NV operation, and
1745 we're outside the range of NV integer precision */
1748 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1749 DEBUG_c(PerlIO_printf(Perl_debug_log,
1750 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1756 /* IV not precise. No need to convert from PV, as NV
1757 conversion would already have cached IV if it detected
1758 that PV->IV would be better than PV->NV->IV
1759 flags already correct - don't set public IOK. */
1760 DEBUG_c(PerlIO_printf(Perl_debug_log,
1761 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1766 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1767 but the cast (NV)IV_MIN rounds to a the value less (more
1768 negative) than IV_MIN which happens to be equal to SvNVX ??
1769 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1770 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1771 (NV)UVX == NVX are both true, but the values differ. :-(
1772 Hopefully for 2s complement IV_MIN is something like
1773 0x8000000000000000 which will be exact. NWC */
1776 SvUVX(sv) = U_V(SvNVX(sv));
1778 (SvNVX(sv) == (NV) SvUVX(sv))
1779 #ifndef NV_PRESERVES_UV
1780 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1781 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1782 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1783 /* Don't flag it as "accurately an integer" if the number
1784 came from a (by definition imprecise) NV operation, and
1785 we're outside the range of NV integer precision */
1791 DEBUG_c(PerlIO_printf(Perl_debug_log,
1792 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1796 return (IV)SvUVX(sv);
1799 else if (SvPOKp(sv) && SvLEN(sv)) {
1800 I32 numtype = looks_like_number(sv);
1802 /* We want to avoid a possible problem when we cache an IV which
1803 may be later translated to an NV, and the resulting NV is not
1804 the translation of the initial data.
1806 This means that if we cache such an IV, we need to cache the
1807 NV as well. Moreover, we trade speed for space, and do not
1808 cache the NV if we are sure it's not needed.
1811 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1812 /* The NV may be reconstructed from IV - safe to cache IV,
1813 which may be calculated by atol(). */
1814 if (SvTYPE(sv) < SVt_PVIV)
1815 sv_upgrade(sv, SVt_PVIV);
1817 SvIVX(sv) = Atol(SvPVX(sv));
1821 int save_errno = errno;
1822 /* Is it an integer that we could convert with strtol?
1823 So try it, and if it doesn't set errno then it's pukka.
1824 This should be faster than going atof and then thinking. */
1825 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1826 == IS_NUMBER_TO_INT_BY_STRTOL)
1827 /* && is a sequence point. Without it not sure if I'm trying
1828 to do too much between sequence points and hence going
1830 && ((errno = 0), 1) /* , 1 so always true */
1831 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1833 if (SvTYPE(sv) < SVt_PVIV)
1834 sv_upgrade(sv, SVt_PVIV);
1843 /* Hopefully trace flow will optimise this away where possible
1847 /* It wasn't an integer, or it overflowed, or we don't have
1848 strtol. Do things the slow way - check if it's a UV etc. */
1849 d = Atof(SvPVX(sv));
1851 if (SvTYPE(sv) < SVt_PVNV)
1852 sv_upgrade(sv, SVt_PVNV);
1855 if (! numtype && ckWARN(WARN_NUMERIC))
1858 #if defined(USE_LONG_DOUBLE)
1859 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1860 PTR2UV(sv), SvNVX(sv)));
1862 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1863 PTR2UV(sv), SvNVX(sv)));
1867 #ifdef NV_PRESERVES_UV
1868 (void)SvIOKp_on(sv);
1870 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1871 SvIVX(sv) = I_V(SvNVX(sv));
1872 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1875 /* Integer is imprecise. NOK, IOKp */
1877 /* UV will not work better than IV */
1879 if (SvNVX(sv) > (NV)UV_MAX) {
1881 /* Integer is inaccurate. NOK, IOKp, is UV */
1885 SvUVX(sv) = U_V(SvNVX(sv));
1886 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1887 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1891 /* Integer is imprecise. NOK, IOKp, is UV */
1897 #else /* NV_PRESERVES_UV */
1898 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1899 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1900 /* Small enough to preserve all bits. */
1901 (void)SvIOKp_on(sv);
1903 SvIVX(sv) = I_V(SvNVX(sv));
1904 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1906 /* Assumption: first non-preserved integer is < IV_MAX,
1907 this NV is in the preserved range, therefore: */
1908 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1910 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);
1912 } else if (sv_2iuv_non_preserve (sv, numtype)
1913 >= IS_NUMBER_OVERFLOW_IV)
1915 #endif /* NV_PRESERVES_UV */
1919 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1921 if (SvTYPE(sv) < SVt_IV)
1922 /* Typically the caller expects that sv_any is not NULL now. */
1923 sv_upgrade(sv, SVt_IV);
1926 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1927 PTR2UV(sv),SvIVX(sv)));
1928 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1932 Perl_sv_2uv(pTHX_ register SV *sv)
1936 if (SvGMAGICAL(sv)) {
1941 return U_V(SvNVX(sv));
1942 if (SvPOKp(sv) && SvLEN(sv))
1945 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1946 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1952 if (SvTHINKFIRST(sv)) {
1955 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1956 (SvRV(tmpstr) != SvRV(sv)))
1957 return SvUV(tmpstr);
1958 return PTR2UV(SvRV(sv));
1960 if (SvREADONLY(sv) && SvFAKE(sv)) {
1961 sv_force_normal(sv);
1963 if (SvREADONLY(sv) && !SvOK(sv)) {
1964 if (ckWARN(WARN_UNINITIALIZED))
1974 return (UV)SvIVX(sv);
1978 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1979 * without also getting a cached IV/UV from it at the same time
1980 * (ie PV->NV conversion should detect loss of accuracy and cache
1981 * IV or UV at same time to avoid this. */
1982 /* IV-over-UV optimisation - choose to cache IV if possible */
1984 if (SvTYPE(sv) == SVt_NV)
1985 sv_upgrade(sv, SVt_PVNV);
1987 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1988 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1989 SvIVX(sv) = I_V(SvNVX(sv));
1990 if (SvNVX(sv) == (NV) SvIVX(sv)
1991 #ifndef NV_PRESERVES_UV
1992 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1993 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1994 /* Don't flag it as "accurately an integer" if the number
1995 came from a (by definition imprecise) NV operation, and
1996 we're outside the range of NV integer precision */
1999 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2000 DEBUG_c(PerlIO_printf(Perl_debug_log,
2001 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2007 /* IV not precise. No need to convert from PV, as NV
2008 conversion would already have cached IV if it detected
2009 that PV->IV would be better than PV->NV->IV
2010 flags already correct - don't set public IOK. */
2011 DEBUG_c(PerlIO_printf(Perl_debug_log,
2012 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2017 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2018 but the cast (NV)IV_MIN rounds to a the value less (more
2019 negative) than IV_MIN which happens to be equal to SvNVX ??
2020 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2021 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2022 (NV)UVX == NVX are both true, but the values differ. :-(
2023 Hopefully for 2s complement IV_MIN is something like
2024 0x8000000000000000 which will be exact. NWC */
2027 SvUVX(sv) = U_V(SvNVX(sv));
2029 (SvNVX(sv) == (NV) SvUVX(sv))
2030 #ifndef NV_PRESERVES_UV
2031 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2032 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2033 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2034 /* Don't flag it as "accurately an integer" if the number
2035 came from a (by definition imprecise) NV operation, and
2036 we're outside the range of NV integer precision */
2041 DEBUG_c(PerlIO_printf(Perl_debug_log,
2042 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2048 else if (SvPOKp(sv) && SvLEN(sv)) {
2049 I32 numtype = looks_like_number(sv);
2051 /* We want to avoid a possible problem when we cache a UV which
2052 may be later translated to an NV, and the resulting NV is not
2053 the translation of the initial data.
2055 This means that if we cache such a UV, we need to cache the
2056 NV as well. Moreover, we trade speed for space, and do not
2057 cache the NV if not needed.
2060 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2061 /* The NV may be reconstructed from IV - safe to cache IV,
2062 which may be calculated by atol(). */
2063 if (SvTYPE(sv) < SVt_PVIV)
2064 sv_upgrade(sv, SVt_PVIV);
2066 SvIVX(sv) = Atol(SvPVX(sv));
2070 int save_errno = errno;
2071 /* Is it an integer that we could convert with strtoul?
2072 So try it, and if it doesn't set errno then it's pukka.
2073 This should be faster than going atof and then thinking. */
2074 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2075 == IS_NUMBER_TO_INT_BY_STRTOL)
2076 && ((errno = 0), 1) /* always true */
2077 && ((u = Strtoul(SvPVX(sv), Null(char**), 10)), 1) /* ditto */
2079 /* If known to be negative, check it didn't undeflow IV */
2080 && ((numtype & IS_NUMBER_NEG) ? ((IV)u <= 0) : 1)) {
2083 if (SvTYPE(sv) < SVt_PVIV)
2084 sv_upgrade(sv, SVt_PVIV);
2087 /* If it's negative must use IV.
2088 IV-over-UV optimisation */
2089 if (numtype & IS_NUMBER_NEG || u <= (UV) IV_MAX) {
2090 /* strtoul is defined to return negated value if the
2091 number starts with a minus sign. Assuming 2s
2092 complement, this value will be in range for a negative
2093 IV if casting the bit pattern to IV doesn't produce
2094 a positive value. Allow -0 by checking it's <= 0
2095 hence (numtype & IS_NUMBER_NEG) test above
2099 /* it didn't overflow, and it was positive. */
2108 /* Hopefully trace flow will optimise this away where possible
2112 /* It wasn't an integer, or it overflowed, or we don't have
2113 strtol. Do things the slow way - check if it's a IV etc. */
2114 d = Atof(SvPVX(sv));
2116 if (SvTYPE(sv) < SVt_PVNV)
2117 sv_upgrade(sv, SVt_PVNV);
2120 if (! numtype && ckWARN(WARN_NUMERIC))
2123 #if defined(USE_LONG_DOUBLE)
2124 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2125 PTR2UV(sv), SvNVX(sv)));
2127 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2128 PTR2UV(sv), SvNVX(sv)));
2131 #ifdef NV_PRESERVES_UV
2132 (void)SvIOKp_on(sv);
2134 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2135 SvIVX(sv) = I_V(SvNVX(sv));
2136 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2139 /* Integer is imprecise. NOK, IOKp */
2141 /* UV will not work better than IV */
2143 if (SvNVX(sv) > (NV)UV_MAX) {
2145 /* Integer is inaccurate. NOK, IOKp, is UV */
2149 SvUVX(sv) = U_V(SvNVX(sv));
2150 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2151 NV preservse UV so can do correct comparison. */
2152 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2156 /* Integer is imprecise. NOK, IOKp, is UV */
2161 #else /* NV_PRESERVES_UV */
2162 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2163 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2164 /* Small enough to preserve all bits. */
2165 (void)SvIOKp_on(sv);
2167 SvIVX(sv) = I_V(SvNVX(sv));
2168 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2170 /* Assumption: first non-preserved integer is < IV_MAX,
2171 this NV is in the preserved range, therefore: */
2172 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2174 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);
2177 sv_2iuv_non_preserve (sv, numtype);
2178 #endif /* NV_PRESERVES_UV */
2183 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2184 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2187 if (SvTYPE(sv) < SVt_IV)
2188 /* Typically the caller expects that sv_any is not NULL now. */
2189 sv_upgrade(sv, SVt_IV);
2193 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2194 PTR2UV(sv),SvUVX(sv)));
2195 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2199 Perl_sv_2nv(pTHX_ register SV *sv)
2203 if (SvGMAGICAL(sv)) {
2207 if (SvPOKp(sv) && SvLEN(sv)) {
2208 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2210 return Atof(SvPVX(sv));
2214 return (NV)SvUVX(sv);
2216 return (NV)SvIVX(sv);
2219 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2220 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2226 if (SvTHINKFIRST(sv)) {
2229 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2230 (SvRV(tmpstr) != SvRV(sv)))
2231 return SvNV(tmpstr);
2232 return PTR2NV(SvRV(sv));
2234 if (SvREADONLY(sv) && SvFAKE(sv)) {
2235 sv_force_normal(sv);
2237 if (SvREADONLY(sv) && !SvOK(sv)) {
2238 if (ckWARN(WARN_UNINITIALIZED))
2243 if (SvTYPE(sv) < SVt_NV) {
2244 if (SvTYPE(sv) == SVt_IV)
2245 sv_upgrade(sv, SVt_PVNV);
2247 sv_upgrade(sv, SVt_NV);
2248 #if defined(USE_LONG_DOUBLE)
2250 STORE_NUMERIC_LOCAL_SET_STANDARD();
2251 PerlIO_printf(Perl_debug_log,
2252 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2253 PTR2UV(sv), SvNVX(sv));
2254 RESTORE_NUMERIC_LOCAL();
2258 STORE_NUMERIC_LOCAL_SET_STANDARD();
2259 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2260 PTR2UV(sv), SvNVX(sv));
2261 RESTORE_NUMERIC_LOCAL();
2265 else if (SvTYPE(sv) < SVt_PVNV)
2266 sv_upgrade(sv, SVt_PVNV);
2268 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2270 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2271 #ifdef NV_PRESERVES_UV
2274 /* Only set the public NV OK flag if this NV preserves the IV */
2275 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2276 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2277 : (SvIVX(sv) == I_V(SvNVX(sv))))
2283 else if (SvPOKp(sv) && SvLEN(sv)) {
2284 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2286 SvNVX(sv) = Atof(SvPVX(sv));
2287 #ifdef NV_PRESERVES_UV
2290 /* Only set the public NV OK flag if this NV preserves the value in
2291 the PV at least as well as an IV/UV would.
2292 Not sure how to do this 100% reliably. */
2293 /* if that shift count is out of range then Configure's test is
2294 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2296 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2297 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2298 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2299 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2300 /* Definitely too large/small to fit in an integer, so no loss
2301 of precision going to integer in the future via NV */
2304 /* Is it something we can run through strtol etc (ie no
2305 trailing exponent part)? */
2306 int numtype = looks_like_number(sv);
2307 /* XXX probably should cache this if called above */
2310 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2311 /* Can't use strtol etc to convert this string, so don't try */
2314 sv_2inuv_non_preserve (sv, numtype);
2316 #endif /* NV_PRESERVES_UV */
2319 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2321 if (SvTYPE(sv) < SVt_NV)
2322 /* Typically the caller expects that sv_any is not NULL now. */
2323 /* XXX Ilya implies that this is a bug in callers that assume this
2324 and ideally should be fixed. */
2325 sv_upgrade(sv, SVt_NV);
2328 #if defined(USE_LONG_DOUBLE)
2330 STORE_NUMERIC_LOCAL_SET_STANDARD();
2331 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2332 PTR2UV(sv), SvNVX(sv));
2333 RESTORE_NUMERIC_LOCAL();
2337 STORE_NUMERIC_LOCAL_SET_STANDARD();
2338 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2339 PTR2UV(sv), SvNVX(sv));
2340 RESTORE_NUMERIC_LOCAL();
2347 S_asIV(pTHX_ SV *sv)
2349 I32 numtype = looks_like_number(sv);
2352 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2353 return Atol(SvPVX(sv));
2355 if (ckWARN(WARN_NUMERIC))
2358 d = Atof(SvPVX(sv));
2363 S_asUV(pTHX_ SV *sv)
2365 I32 numtype = looks_like_number(sv);
2368 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2369 return Strtoul(SvPVX(sv), Null(char**), 10);
2372 if (ckWARN(WARN_NUMERIC))
2375 return U_V(Atof(SvPVX(sv)));
2379 * Returns a combination of (advisory only - can get false negatives)
2380 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2381 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2382 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2383 * 0 if does not look like number.
2385 * (atol and strtol stop when they hit a decimal point. strtol will return
2386 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2387 * do this, and vendors have had 11 years to get it right.
2388 * However, will try to make it still work with only atol
2390 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2391 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2392 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2393 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2394 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2395 * IS_NUMBER_NOT_INT saw "." or "e"
2397 * IS_NUMBER_INFINITY
2401 =for apidoc looks_like_number
2403 Test if an the content of an SV looks like a number (or is a
2404 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2405 issue a non-numeric warning), even if your atof() doesn't grok them.
2411 Perl_looks_like_number(pTHX_ SV *sv)
2414 register char *send;
2415 register char *sbegin;
2416 register char *nbegin;
2425 else if (SvPOKp(sv))
2426 sbegin = SvPV(sv, len);
2429 send = sbegin + len;
2436 numtype = IS_NUMBER_NEG;
2443 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2444 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2445 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2446 * will need (int)atof().
2449 /* next must be digit or the radix separator or beginning of infinity */
2453 } while (isDIGIT(*s));
2455 /* Aaargh. long long really is irritating.
2456 In the gospel according to ANSI 1989, it is an axiom that "long"
2457 is the longest integer type, and that if you don't know how long
2458 something is you can cast it to long, and nothing will be lost
2459 (except possibly speed of execution if long is slower than the
2461 Now, one can't be sure if the old rules apply, or long long
2462 (or some other newfangled thing) is actually longer than the
2463 (formerly) longest thing.
2465 /* This lot will work for 64 bit *as long as* either
2466 either long is 64 bit
2467 or we can find both strtol/strtoq and strtoul/strtouq
2468 If not, we really should refuse to let the user use 64 bit IVs
2469 By "64 bit" I really mean IVs that don't get preserved by NVs
2470 It also should work for 128 bit IVs. Can any lend me a machine to
2473 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2474 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2475 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2476 ? sizeof(long) : sizeof (IV))*8-1))
2477 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2479 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2480 digit less (IV_MAX= 9223372036854775807,
2481 UV_MAX= 18446744073709551615) so be cautious */
2482 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2485 #ifdef USE_LOCALE_NUMERIC
2486 || IS_NUMERIC_RADIX(*s)
2490 numtype |= IS_NUMBER_NOT_INT;
2491 while (isDIGIT(*s)) /* optional digits after the radix */
2496 #ifdef USE_LOCALE_NUMERIC
2497 || IS_NUMERIC_RADIX(*s)
2501 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2502 /* no digits before the radix means we need digits after it */
2506 } while (isDIGIT(*s));
2511 else if (*s == 'I' || *s == 'i') {
2512 s++; if (*s != 'N' && *s != 'n') return 0;
2513 s++; if (*s != 'F' && *s != 'f') return 0;
2514 s++; if (*s == 'I' || *s == 'i') {
2515 s++; if (*s != 'N' && *s != 'n') return 0;
2516 s++; if (*s != 'I' && *s != 'i') return 0;
2517 s++; if (*s != 'T' && *s != 't') return 0;
2518 s++; if (*s != 'Y' && *s != 'y') return 0;
2527 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2528 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2530 /* we can have an optional exponent part */
2531 if (*s == 'e' || *s == 'E') {
2532 numtype &= IS_NUMBER_NEG;
2533 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2535 if (*s == '+' || *s == '-')
2540 } while (isDIGIT(*s));
2550 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2551 return IS_NUMBER_TO_INT_BY_ATOL;
2556 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2559 return sv_2pv(sv, &n_a);
2562 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2564 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2566 char *ptr = buf + TYPE_CHARS(UV);
2580 *--ptr = '0' + (uv % 10);
2589 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2594 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2595 char *tmpbuf = tbuf;
2601 if (SvGMAGICAL(sv)) {
2609 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2611 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2616 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2621 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2622 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2629 if (SvTHINKFIRST(sv)) {
2632 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2633 (SvRV(tmpstr) != SvRV(sv)))
2634 return SvPV(tmpstr,*lp);
2641 switch (SvTYPE(sv)) {
2643 if ( ((SvFLAGS(sv) &
2644 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2645 == (SVs_OBJECT|SVs_RMG))
2646 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2647 && (mg = mg_find(sv, 'r'))) {
2648 regexp *re = (regexp *)mg->mg_obj;
2651 char *fptr = "msix";
2656 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2658 while((ch = *fptr++)) {
2660 reflags[left++] = ch;
2663 reflags[right--] = ch;
2668 reflags[left] = '-';
2672 mg->mg_len = re->prelen + 4 + left;
2673 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2674 Copy("(?", mg->mg_ptr, 2, char);
2675 Copy(reflags, mg->mg_ptr+2, left, char);
2676 Copy(":", mg->mg_ptr+left+2, 1, char);
2677 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2678 mg->mg_ptr[mg->mg_len - 1] = ')';
2679 mg->mg_ptr[mg->mg_len] = 0;
2681 PL_reginterp_cnt += re->program[0].next_off;
2693 case SVt_PVBM: if (SvROK(sv))
2696 s = "SCALAR"; break;
2697 case SVt_PVLV: s = "LVALUE"; break;
2698 case SVt_PVAV: s = "ARRAY"; break;
2699 case SVt_PVHV: s = "HASH"; break;
2700 case SVt_PVCV: s = "CODE"; break;
2701 case SVt_PVGV: s = "GLOB"; break;
2702 case SVt_PVFM: s = "FORMAT"; break;
2703 case SVt_PVIO: s = "IO"; break;
2704 default: s = "UNKNOWN"; break;
2708 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2711 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2717 if (SvREADONLY(sv) && !SvOK(sv)) {
2718 if (ckWARN(WARN_UNINITIALIZED))
2724 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2725 /* I'm assuming that if both IV and NV are equally valid then
2726 converting the IV is going to be more efficient */
2727 U32 isIOK = SvIOK(sv);
2728 U32 isUIOK = SvIsUV(sv);
2729 char buf[TYPE_CHARS(UV)];
2732 if (SvTYPE(sv) < SVt_PVIV)
2733 sv_upgrade(sv, SVt_PVIV);
2735 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2737 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2738 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2739 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2740 SvCUR_set(sv, ebuf - ptr);
2750 else if (SvNOKp(sv)) {
2751 if (SvTYPE(sv) < SVt_PVNV)
2752 sv_upgrade(sv, SVt_PVNV);
2753 /* The +20 is pure guesswork. Configure test needed. --jhi */
2754 SvGROW(sv, NV_DIG + 20);
2756 olderrno = errno; /* some Xenix systems wipe out errno here */
2758 if (SvNVX(sv) == 0.0)
2759 (void)strcpy(s,"0");
2763 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2766 #ifdef FIXNEGATIVEZERO
2767 if (*s == '-' && s[1] == '0' && !s[2])
2777 if (ckWARN(WARN_UNINITIALIZED)
2778 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2781 if (SvTYPE(sv) < SVt_PV)
2782 /* Typically the caller expects that sv_any is not NULL now. */
2783 sv_upgrade(sv, SVt_PV);
2786 *lp = s - SvPVX(sv);
2789 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2790 PTR2UV(sv),SvPVX(sv)));
2794 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2795 /* Sneaky stuff here */
2799 tsv = newSVpv(tmpbuf, 0);
2815 len = strlen(tmpbuf);
2817 #ifdef FIXNEGATIVEZERO
2818 if (len == 2 && t[0] == '-' && t[1] == '0') {
2823 (void)SvUPGRADE(sv, SVt_PV);
2825 s = SvGROW(sv, len + 1);
2834 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2837 return sv_2pvbyte(sv, &n_a);
2841 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2843 return sv_2pv(sv,lp);
2847 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2850 return sv_2pvutf8(sv, &n_a);
2854 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2856 sv_utf8_upgrade(sv);
2857 return SvPV(sv,*lp);
2860 /* This function is only called on magical items */
2862 Perl_sv_2bool(pTHX_ register SV *sv)
2871 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2872 (SvRV(tmpsv) != SvRV(sv)))
2873 return SvTRUE(tmpsv);
2874 return SvRV(sv) != 0;
2877 register XPV* Xpvtmp;
2878 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2879 (*Xpvtmp->xpv_pv > '0' ||
2880 Xpvtmp->xpv_cur > 1 ||
2881 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2888 return SvIVX(sv) != 0;
2891 return SvNVX(sv) != 0.0;
2899 =for apidoc sv_utf8_upgrade
2901 Convert the PV of an SV to its UTF8-encoded form.
2907 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2912 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2915 /* This function could be much more efficient if we had a FLAG in SVs
2916 * to signal if there are any hibit chars in the PV.
2917 * Given that there isn't make loop fast as possible
2923 if ((hibit = *t++ & 0x80))
2929 if (SvREADONLY(sv) && SvFAKE(sv)) {
2930 sv_force_normal(sv);
2933 len = SvCUR(sv) + 1; /* Plus the \0 */
2934 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2935 SvCUR(sv) = len - 1;
2937 Safefree(s); /* No longer using what was there before. */
2938 SvLEN(sv) = len; /* No longer know the real size. */
2944 =for apidoc sv_utf8_downgrade
2946 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2947 This may not be possible if the PV contains non-byte encoding characters;
2948 if this is the case, either returns false or, if C<fail_ok> is not
2955 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2957 if (SvPOK(sv) && SvUTF8(sv)) {
2959 char *c = SvPVX(sv);
2960 STRLEN len = SvCUR(sv);
2962 if (!utf8_to_bytes((U8*)c, &len)) {
2967 Perl_croak(aTHX_ "Wide character in %s",
2968 PL_op_desc[PL_op->op_type]);
2970 Perl_croak(aTHX_ "Wide character");
2982 =for apidoc sv_utf8_encode
2984 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2985 flag so that it looks like bytes again. Nothing calls this.
2991 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2993 sv_utf8_upgrade(sv);
2998 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3003 bool has_utf = FALSE;
3004 if (!sv_utf8_downgrade(sv, TRUE))
3007 /* it is actually just a matter of turning the utf8 flag on, but
3008 * we want to make sure everything inside is valid utf8 first.
3011 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
3025 /* Note: sv_setsv() should not be called with a source string that needs
3026 * to be reused, since it may destroy the source string if it is marked
3031 =for apidoc sv_setsv
3033 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3034 The source SV may be destroyed if it is mortal. Does not handle 'set'
3035 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3042 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3044 register U32 sflags;
3050 SV_CHECK_THINKFIRST(dstr);
3052 sstr = &PL_sv_undef;
3053 stype = SvTYPE(sstr);
3054 dtype = SvTYPE(dstr);
3058 /* There's a lot of redundancy below but we're going for speed here */
3063 if (dtype != SVt_PVGV) {
3064 (void)SvOK_off(dstr);
3072 sv_upgrade(dstr, SVt_IV);
3075 sv_upgrade(dstr, SVt_PVNV);
3079 sv_upgrade(dstr, SVt_PVIV);
3082 (void)SvIOK_only(dstr);
3083 SvIVX(dstr) = SvIVX(sstr);
3086 if (SvTAINTED(sstr))
3097 sv_upgrade(dstr, SVt_NV);
3102 sv_upgrade(dstr, SVt_PVNV);
3105 SvNVX(dstr) = SvNVX(sstr);
3106 (void)SvNOK_only(dstr);
3107 if (SvTAINTED(sstr))
3115 sv_upgrade(dstr, SVt_RV);
3116 else if (dtype == SVt_PVGV &&
3117 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3120 if (GvIMPORTED(dstr) != GVf_IMPORTED
3121 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3123 GvIMPORTED_on(dstr);
3134 sv_upgrade(dstr, SVt_PV);
3137 if (dtype < SVt_PVIV)
3138 sv_upgrade(dstr, SVt_PVIV);
3141 if (dtype < SVt_PVNV)
3142 sv_upgrade(dstr, SVt_PVNV);
3149 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3150 PL_op_name[PL_op->op_type]);
3152 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3156 if (dtype <= SVt_PVGV) {
3158 if (dtype != SVt_PVGV) {
3159 char *name = GvNAME(sstr);
3160 STRLEN len = GvNAMELEN(sstr);
3161 sv_upgrade(dstr, SVt_PVGV);
3162 sv_magic(dstr, dstr, '*', Nullch, 0);
3163 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3164 GvNAME(dstr) = savepvn(name, len);
3165 GvNAMELEN(dstr) = len;
3166 SvFAKE_on(dstr); /* can coerce to non-glob */
3168 /* ahem, death to those who redefine active sort subs */
3169 else if (PL_curstackinfo->si_type == PERLSI_SORT
3170 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3171 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3173 (void)SvOK_off(dstr);
3174 GvINTRO_off(dstr); /* one-shot flag */
3176 GvGP(dstr) = gp_ref(GvGP(sstr));
3177 if (SvTAINTED(sstr))
3179 if (GvIMPORTED(dstr) != GVf_IMPORTED
3180 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3182 GvIMPORTED_on(dstr);
3190 if (SvGMAGICAL(sstr)) {
3192 if (SvTYPE(sstr) != stype) {
3193 stype = SvTYPE(sstr);
3194 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3198 if (stype == SVt_PVLV)
3199 (void)SvUPGRADE(dstr, SVt_PVNV);
3201 (void)SvUPGRADE(dstr, stype);
3204 sflags = SvFLAGS(sstr);
3206 if (sflags & SVf_ROK) {
3207 if (dtype >= SVt_PV) {
3208 if (dtype == SVt_PVGV) {
3209 SV *sref = SvREFCNT_inc(SvRV(sstr));
3211 int intro = GvINTRO(dstr);
3216 GvINTRO_off(dstr); /* one-shot flag */
3217 Newz(602,gp, 1, GP);
3218 GvGP(dstr) = gp_ref(gp);
3219 GvSV(dstr) = NEWSV(72,0);
3220 GvLINE(dstr) = CopLINE(PL_curcop);
3221 GvEGV(dstr) = (GV*)dstr;
3224 switch (SvTYPE(sref)) {
3227 SAVESPTR(GvAV(dstr));
3229 dref = (SV*)GvAV(dstr);
3230 GvAV(dstr) = (AV*)sref;
3231 if (!GvIMPORTED_AV(dstr)
3232 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3234 GvIMPORTED_AV_on(dstr);
3239 SAVESPTR(GvHV(dstr));
3241 dref = (SV*)GvHV(dstr);
3242 GvHV(dstr) = (HV*)sref;
3243 if (!GvIMPORTED_HV(dstr)
3244 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3246 GvIMPORTED_HV_on(dstr);
3251 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3252 SvREFCNT_dec(GvCV(dstr));
3253 GvCV(dstr) = Nullcv;
3254 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3255 PL_sub_generation++;
3257 SAVESPTR(GvCV(dstr));
3260 dref = (SV*)GvCV(dstr);
3261 if (GvCV(dstr) != (CV*)sref) {
3262 CV* cv = GvCV(dstr);
3264 if (!GvCVGEN((GV*)dstr) &&
3265 (CvROOT(cv) || CvXSUB(cv)))
3268 /* ahem, death to those who redefine
3269 * active sort subs */
3270 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3271 PL_sortcop == CvSTART(cv))
3273 "Can't redefine active sort subroutine %s",
3274 GvENAME((GV*)dstr));
3275 /* Redefining a sub - warning is mandatory if
3276 it was a const and its value changed. */
3277 if (ckWARN(WARN_REDEFINE)
3279 && (!CvCONST((CV*)sref)
3280 || sv_cmp(cv_const_sv(cv),
3281 cv_const_sv((CV*)sref)))))
3283 Perl_warner(aTHX_ WARN_REDEFINE,
3285 ? "Constant subroutine %s redefined"
3286 : "Subroutine %s redefined",
3287 GvENAME((GV*)dstr));
3290 cv_ckproto(cv, (GV*)dstr,
3291 SvPOK(sref) ? SvPVX(sref) : Nullch);
3293 GvCV(dstr) = (CV*)sref;
3294 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3295 GvASSUMECV_on(dstr);
3296 PL_sub_generation++;
3298 if (!GvIMPORTED_CV(dstr)
3299 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3301 GvIMPORTED_CV_on(dstr);
3306 SAVESPTR(GvIOp(dstr));
3308 dref = (SV*)GvIOp(dstr);
3309 GvIOp(dstr) = (IO*)sref;
3313 SAVESPTR(GvFORM(dstr));
3315 dref = (SV*)GvFORM(dstr);
3316 GvFORM(dstr) = (CV*)sref;
3320 SAVESPTR(GvSV(dstr));
3322 dref = (SV*)GvSV(dstr);
3324 if (!GvIMPORTED_SV(dstr)
3325 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3327 GvIMPORTED_SV_on(dstr);
3335 if (SvTAINTED(sstr))
3340 (void)SvOOK_off(dstr); /* backoff */
3342 Safefree(SvPVX(dstr));
3343 SvLEN(dstr)=SvCUR(dstr)=0;
3346 (void)SvOK_off(dstr);
3347 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3349 if (sflags & SVp_NOK) {
3351 SvNVX(dstr) = SvNVX(sstr);
3353 if (sflags & SVp_IOK) {
3354 (void)SvIOK_on(dstr);
3355 SvIVX(dstr) = SvIVX(sstr);
3356 if (sflags & SVf_IVisUV)
3359 if (SvAMAGIC(sstr)) {
3363 else if (sflags & SVp_POK) {
3366 * Check to see if we can just swipe the string. If so, it's a
3367 * possible small lose on short strings, but a big win on long ones.
3368 * It might even be a win on short strings if SvPVX(dstr)
3369 * has to be allocated and SvPVX(sstr) has to be freed.
3372 if (SvTEMP(sstr) && /* slated for free anyway? */
3373 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3374 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3375 SvLEN(sstr) && /* and really is a string */
3376 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3378 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3380 SvFLAGS(dstr) &= ~SVf_OOK;
3381 Safefree(SvPVX(dstr) - SvIVX(dstr));
3383 else if (SvLEN(dstr))
3384 Safefree(SvPVX(dstr));
3386 (void)SvPOK_only(dstr);
3387 SvPV_set(dstr, SvPVX(sstr));
3388 SvLEN_set(dstr, SvLEN(sstr));
3389 SvCUR_set(dstr, SvCUR(sstr));
3392 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3393 SvPV_set(sstr, Nullch);
3398 else { /* have to copy actual string */
3399 STRLEN len = SvCUR(sstr);
3401 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3402 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3403 SvCUR_set(dstr, len);
3404 *SvEND(dstr) = '\0';
3405 (void)SvPOK_only(dstr);
3407 if ((sflags & SVf_UTF8) && !IN_BYTE)
3410 if (sflags & SVp_NOK) {
3412 SvNVX(dstr) = SvNVX(sstr);
3414 if (sflags & SVp_IOK) {
3415 (void)SvIOK_on(dstr);
3416 SvIVX(dstr) = SvIVX(sstr);
3417 if (sflags & SVf_IVisUV)
3421 else if (sflags & SVp_NOK) {
3422 SvNVX(dstr) = SvNVX(sstr);
3423 (void)SvNOK_only(dstr);
3424 if (sflags & SVf_IOK) {
3425 (void)SvIOK_on(dstr);
3426 SvIVX(dstr) = SvIVX(sstr);
3427 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3428 if (sflags & SVf_IVisUV)
3432 else if (sflags & SVp_IOK) {
3433 (void)SvIOK_only(dstr);
3434 SvIVX(dstr) = SvIVX(sstr);
3435 if (sflags & SVf_IVisUV)
3439 if (dtype == SVt_PVGV) {
3440 if (ckWARN(WARN_MISC))
3441 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3444 (void)SvOK_off(dstr);
3446 if (SvTAINTED(sstr))
3451 =for apidoc sv_setsv_mg
3453 Like C<sv_setsv>, but also handles 'set' magic.
3459 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3461 sv_setsv(dstr,sstr);
3466 =for apidoc sv_setpvn
3468 Copies a string into an SV. The C<len> parameter indicates the number of
3469 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3475 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3477 register char *dptr;
3479 /* len is STRLEN which is unsigned, need to copy to signed */
3483 SV_CHECK_THINKFIRST(sv);
3488 (void)SvUPGRADE(sv, SVt_PV);
3490 SvGROW(sv, len + 1);
3492 Move(ptr,dptr,len,char);
3495 (void)SvPOK_only(sv); /* validate pointer */
3500 =for apidoc sv_setpvn_mg
3502 Like C<sv_setpvn>, but also handles 'set' magic.
3508 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3510 sv_setpvn(sv,ptr,len);
3515 =for apidoc sv_setpv
3517 Copies a string into an SV. The string must be null-terminated. Does not
3518 handle 'set' magic. See C<sv_setpv_mg>.
3524 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3526 register STRLEN len;
3528 SV_CHECK_THINKFIRST(sv);
3534 (void)SvUPGRADE(sv, SVt_PV);
3536 SvGROW(sv, len + 1);
3537 Move(ptr,SvPVX(sv),len+1,char);
3539 (void)SvPOK_only(sv); /* validate pointer */
3544 =for apidoc sv_setpv_mg
3546 Like C<sv_setpv>, but also handles 'set' magic.
3552 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3559 =for apidoc sv_usepvn
3561 Tells an SV to use C<ptr> to find its string value. Normally the string is
3562 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3563 The C<ptr> should point to memory that was allocated by C<malloc>. The
3564 string length, C<len>, must be supplied. This function will realloc the
3565 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3566 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3567 See C<sv_usepvn_mg>.
3573 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3575 SV_CHECK_THINKFIRST(sv);
3576 (void)SvUPGRADE(sv, SVt_PV);
3581 (void)SvOOK_off(sv);
3582 if (SvPVX(sv) && SvLEN(sv))
3583 Safefree(SvPVX(sv));
3584 Renew(ptr, len+1, char);
3587 SvLEN_set(sv, len+1);
3589 (void)SvPOK_only(sv); /* validate pointer */
3594 =for apidoc sv_usepvn_mg
3596 Like C<sv_usepvn>, but also handles 'set' magic.
3602 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3604 sv_usepvn(sv,ptr,len);
3609 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3611 if (SvREADONLY(sv)) {
3613 char *pvx = SvPVX(sv);
3614 STRLEN len = SvCUR(sv);
3615 U32 hash = SvUVX(sv);
3616 SvGROW(sv, len + 1);
3617 Move(pvx,SvPVX(sv),len,char);
3621 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3623 else if (PL_curcop != &PL_compiling)
3624 Perl_croak(aTHX_ PL_no_modify);
3627 sv_unref_flags(sv, flags);
3628 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3633 Perl_sv_force_normal(pTHX_ register SV *sv)
3635 sv_force_normal_flags(sv, 0);
3641 Efficient removal of characters from the beginning of the string buffer.
3642 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3643 the string buffer. The C<ptr> becomes the first character of the adjusted
3650 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3654 register STRLEN delta;
3656 if (!ptr || !SvPOKp(sv))
3658 SV_CHECK_THINKFIRST(sv);
3659 if (SvTYPE(sv) < SVt_PVIV)
3660 sv_upgrade(sv,SVt_PVIV);
3663 if (!SvLEN(sv)) { /* make copy of shared string */
3664 char *pvx = SvPVX(sv);
3665 STRLEN len = SvCUR(sv);
3666 SvGROW(sv, len + 1);
3667 Move(pvx,SvPVX(sv),len,char);
3671 SvFLAGS(sv) |= SVf_OOK;
3673 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3674 delta = ptr - SvPVX(sv);
3682 =for apidoc sv_catpvn
3684 Concatenates the string onto the end of the string which is in the SV. The
3685 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3686 'set' magic. See C<sv_catpvn_mg>.
3692 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3697 junk = SvPV_force(sv, tlen);
3698 SvGROW(sv, tlen + len + 1);
3701 Move(ptr,SvPVX(sv)+tlen,len,char);
3704 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3709 =for apidoc sv_catpvn_mg
3711 Like C<sv_catpvn>, but also handles 'set' magic.
3717 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3719 sv_catpvn(sv,ptr,len);
3724 =for apidoc sv_catsv
3726 Concatenates the string from SV C<ssv> onto the end of the string in SV
3727 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3733 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3739 if ((s = SvPV(sstr, len))) {
3740 if (DO_UTF8(sstr)) {
3741 sv_utf8_upgrade(dstr);
3742 sv_catpvn(dstr,s,len);
3746 sv_catpvn(dstr,s,len);
3751 =for apidoc sv_catsv_mg
3753 Like C<sv_catsv>, but also handles 'set' magic.
3759 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3761 sv_catsv(dstr,sstr);
3766 =for apidoc sv_catpv
3768 Concatenates the string onto the end of the string which is in the SV.
3769 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3775 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3777 register STRLEN len;
3783 junk = SvPV_force(sv, tlen);
3785 SvGROW(sv, tlen + len + 1);
3788 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3790 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3795 =for apidoc sv_catpv_mg
3797 Like C<sv_catpv>, but also handles 'set' magic.
3803 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3810 Perl_newSV(pTHX_ STRLEN len)
3816 sv_upgrade(sv, SVt_PV);
3817 SvGROW(sv, len + 1);
3822 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3825 =for apidoc sv_magic
3827 Adds magic to an SV.
3833 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3837 if (SvREADONLY(sv)) {
3838 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3839 Perl_croak(aTHX_ PL_no_modify);
3841 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3842 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3849 (void)SvUPGRADE(sv, SVt_PVMG);
3851 Newz(702,mg, 1, MAGIC);
3852 mg->mg_moremagic = SvMAGIC(sv);
3855 if (!obj || obj == sv || how == '#' || how == 'r')
3858 mg->mg_obj = SvREFCNT_inc(obj);
3859 mg->mg_flags |= MGf_REFCOUNTED;
3862 mg->mg_len = namlen;
3865 mg->mg_ptr = savepvn(name, namlen);
3866 else if (namlen == HEf_SVKEY)
3867 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3871 mg->mg_virtual = &PL_vtbl_sv;
3874 mg->mg_virtual = &PL_vtbl_amagic;
3877 mg->mg_virtual = &PL_vtbl_amagicelem;
3883 mg->mg_virtual = &PL_vtbl_bm;
3886 mg->mg_virtual = &PL_vtbl_regdata;
3889 mg->mg_virtual = &PL_vtbl_regdatum;
3892 mg->mg_virtual = &PL_vtbl_env;
3895 mg->mg_virtual = &PL_vtbl_fm;
3898 mg->mg_virtual = &PL_vtbl_envelem;
3901 mg->mg_virtual = &PL_vtbl_mglob;
3904 mg->mg_virtual = &PL_vtbl_isa;
3907 mg->mg_virtual = &PL_vtbl_isaelem;
3910 mg->mg_virtual = &PL_vtbl_nkeys;
3917 mg->mg_virtual = &PL_vtbl_dbline;
3921 mg->mg_virtual = &PL_vtbl_mutex;
3923 #endif /* USE_THREADS */
3924 #ifdef USE_LOCALE_COLLATE
3926 mg->mg_virtual = &PL_vtbl_collxfrm;
3928 #endif /* USE_LOCALE_COLLATE */
3930 mg->mg_virtual = &PL_vtbl_pack;
3934 mg->mg_virtual = &PL_vtbl_packelem;
3937 mg->mg_virtual = &PL_vtbl_regexp;
3940 mg->mg_virtual = &PL_vtbl_sig;
3943 mg->mg_virtual = &PL_vtbl_sigelem;
3946 mg->mg_virtual = &PL_vtbl_taint;
3950 mg->mg_virtual = &PL_vtbl_uvar;
3953 mg->mg_virtual = &PL_vtbl_vec;
3956 mg->mg_virtual = &PL_vtbl_substr;
3959 mg->mg_virtual = &PL_vtbl_defelem;
3962 mg->mg_virtual = &PL_vtbl_glob;
3965 mg->mg_virtual = &PL_vtbl_arylen;
3968 mg->mg_virtual = &PL_vtbl_pos;
3971 mg->mg_virtual = &PL_vtbl_backref;
3973 case '~': /* Reserved for use by extensions not perl internals. */
3974 /* Useful for attaching extension internal data to perl vars. */
3975 /* Note that multiple extensions may clash if magical scalars */
3976 /* etc holding private data from one are passed to another. */
3980 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3984 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3988 =for apidoc sv_unmagic
3990 Removes magic from an SV.
3996 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4000 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4003 for (mg = *mgp; mg; mg = *mgp) {
4004 if (mg->mg_type == type) {
4005 MGVTBL* vtbl = mg->mg_virtual;
4006 *mgp = mg->mg_moremagic;
4007 if (vtbl && vtbl->svt_free)
4008 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4009 if (mg->mg_ptr && mg->mg_type != 'g')
4010 if (mg->mg_len >= 0)
4011 Safefree(mg->mg_ptr);
4012 else if (mg->mg_len == HEf_SVKEY)
4013 SvREFCNT_dec((SV*)mg->mg_ptr);
4014 if (mg->mg_flags & MGf_REFCOUNTED)
4015 SvREFCNT_dec(mg->mg_obj);
4019 mgp = &mg->mg_moremagic;
4023 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4030 =for apidoc sv_rvweaken
4038 Perl_sv_rvweaken(pTHX_ SV *sv)
4041 if (!SvOK(sv)) /* let undefs pass */
4044 Perl_croak(aTHX_ "Can't weaken a nonreference");
4045 else if (SvWEAKREF(sv)) {
4046 if (ckWARN(WARN_MISC))
4047 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4051 sv_add_backref(tsv, sv);
4058 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4062 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4063 av = (AV*)mg->mg_obj;
4066 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4067 SvREFCNT_dec(av); /* for sv_magic */
4073 S_sv_del_backref(pTHX_ SV *sv)
4080 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4081 Perl_croak(aTHX_ "panic: del_backref");
4082 av = (AV *)mg->mg_obj;
4087 svp[i] = &PL_sv_undef; /* XXX */
4094 =for apidoc sv_insert
4096 Inserts a string at the specified offset/length within the SV. Similar to
4097 the Perl substr() function.
4103 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4107 register char *midend;
4108 register char *bigend;
4114 Perl_croak(aTHX_ "Can't modify non-existent substring");
4115 SvPV_force(bigstr, curlen);
4116 (void)SvPOK_only_UTF8(bigstr);
4117 if (offset + len > curlen) {
4118 SvGROW(bigstr, offset+len+1);
4119 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4120 SvCUR_set(bigstr, offset+len);
4124 i = littlelen - len;
4125 if (i > 0) { /* string might grow */
4126 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4127 mid = big + offset + len;
4128 midend = bigend = big + SvCUR(bigstr);
4131 while (midend > mid) /* shove everything down */
4132 *--bigend = *--midend;
4133 Move(little,big+offset,littlelen,char);
4139 Move(little,SvPVX(bigstr)+offset,len,char);
4144 big = SvPVX(bigstr);
4147 bigend = big + SvCUR(bigstr);
4149 if (midend > bigend)
4150 Perl_croak(aTHX_ "panic: sv_insert");
4152 if (mid - big > bigend - midend) { /* faster to shorten from end */
4154 Move(little, mid, littlelen,char);
4157 i = bigend - midend;
4159 Move(midend, mid, i,char);
4163 SvCUR_set(bigstr, mid - big);
4166 else if ((i = mid - big)) { /* faster from front */
4167 midend -= littlelen;
4169 sv_chop(bigstr,midend-i);
4174 Move(little, mid, littlelen,char);
4176 else if (littlelen) {
4177 midend -= littlelen;
4178 sv_chop(bigstr,midend);
4179 Move(little,midend,littlelen,char);
4182 sv_chop(bigstr,midend);
4188 =for apidoc sv_replace
4190 Make the first argument a copy of the second, then delete the original.
4196 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4198 U32 refcnt = SvREFCNT(sv);
4199 SV_CHECK_THINKFIRST(sv);
4200 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4201 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4202 if (SvMAGICAL(sv)) {
4206 sv_upgrade(nsv, SVt_PVMG);
4207 SvMAGIC(nsv) = SvMAGIC(sv);
4208 SvFLAGS(nsv) |= SvMAGICAL(sv);
4214 assert(!SvREFCNT(sv));
4215 StructCopy(nsv,sv,SV);
4216 SvREFCNT(sv) = refcnt;
4217 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4222 =for apidoc sv_clear
4224 Clear an SV, making it empty. Does not free the memory used by the SV
4231 Perl_sv_clear(pTHX_ register SV *sv)
4235 assert(SvREFCNT(sv) == 0);
4238 if (PL_defstash) { /* Still have a symbol table? */
4243 Zero(&tmpref, 1, SV);
4244 sv_upgrade(&tmpref, SVt_RV);
4246 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4247 SvREFCNT(&tmpref) = 1;
4250 stash = SvSTASH(sv);
4251 destructor = StashHANDLER(stash,DESTROY);
4254 PUSHSTACKi(PERLSI_DESTROY);
4255 SvRV(&tmpref) = SvREFCNT_inc(sv);
4260 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4266 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4268 del_XRV(SvANY(&tmpref));
4271 if (PL_in_clean_objs)
4272 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4274 /* DESTROY gave object new lease on life */
4280 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4281 SvOBJECT_off(sv); /* Curse the object. */
4282 if (SvTYPE(sv) != SVt_PVIO)
4283 --PL_sv_objcount; /* XXX Might want something more general */
4286 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4289 switch (SvTYPE(sv)) {
4292 IoIFP(sv) != PerlIO_stdin() &&
4293 IoIFP(sv) != PerlIO_stdout() &&
4294 IoIFP(sv) != PerlIO_stderr())
4296 io_close((IO*)sv, FALSE);
4298 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4299 PerlDir_close(IoDIRP(sv));
4300 IoDIRP(sv) = (DIR*)NULL;
4301 Safefree(IoTOP_NAME(sv));
4302 Safefree(IoFMT_NAME(sv));
4303 Safefree(IoBOTTOM_NAME(sv));
4318 SvREFCNT_dec(LvTARG(sv));
4322 Safefree(GvNAME(sv));
4323 /* cannot decrease stash refcount yet, as we might recursively delete
4324 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4325 of stash until current sv is completely gone.
4326 -- JohnPC, 27 Mar 1998 */
4327 stash = GvSTASH(sv);
4333 (void)SvOOK_off(sv);
4341 SvREFCNT_dec(SvRV(sv));
4343 else if (SvPVX(sv) && SvLEN(sv))
4344 Safefree(SvPVX(sv));
4345 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4346 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4358 switch (SvTYPE(sv)) {
4374 del_XPVIV(SvANY(sv));
4377 del_XPVNV(SvANY(sv));
4380 del_XPVMG(SvANY(sv));
4383 del_XPVLV(SvANY(sv));
4386 del_XPVAV(SvANY(sv));
4389 del_XPVHV(SvANY(sv));
4392 del_XPVCV(SvANY(sv));
4395 del_XPVGV(SvANY(sv));
4396 /* code duplication for increased performance. */
4397 SvFLAGS(sv) &= SVf_BREAK;
4398 SvFLAGS(sv) |= SVTYPEMASK;
4399 /* decrease refcount of the stash that owns this GV, if any */
4401 SvREFCNT_dec(stash);
4402 return; /* not break, SvFLAGS reset already happened */
4404 del_XPVBM(SvANY(sv));
4407 del_XPVFM(SvANY(sv));
4410 del_XPVIO(SvANY(sv));
4413 SvFLAGS(sv) &= SVf_BREAK;
4414 SvFLAGS(sv) |= SVTYPEMASK;
4418 Perl_sv_newref(pTHX_ SV *sv)
4421 ATOMIC_INC(SvREFCNT(sv));
4428 Free the memory used by an SV.
4434 Perl_sv_free(pTHX_ SV *sv)
4436 int refcount_is_zero;
4440 if (SvREFCNT(sv) == 0) {
4441 if (SvFLAGS(sv) & SVf_BREAK)
4443 if (PL_in_clean_all) /* All is fair */
4445 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4446 /* make sure SvREFCNT(sv)==0 happens very seldom */
4447 SvREFCNT(sv) = (~(U32)0)/2;
4450 if (ckWARN_d(WARN_INTERNAL))
4451 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4454 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4455 if (!refcount_is_zero)
4459 if (ckWARN_d(WARN_DEBUGGING))
4460 Perl_warner(aTHX_ WARN_DEBUGGING,
4461 "Attempt to free temp prematurely: SV 0x%"UVxf,
4466 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4467 /* make sure SvREFCNT(sv)==0 happens very seldom */
4468 SvREFCNT(sv) = (~(U32)0)/2;
4479 Returns the length of the string in the SV. See also C<SvCUR>.
4485 Perl_sv_len(pTHX_ register SV *sv)
4494 len = mg_length(sv);
4496 junk = SvPV(sv, len);
4501 =for apidoc sv_len_utf8
4503 Returns the number of characters in the string in an SV, counting wide
4504 UTF8 bytes as a single character.
4510 Perl_sv_len_utf8(pTHX_ register SV *sv)
4517 return mg_length(sv);
4522 U8 *s = (U8*)SvPV(sv, len);
4524 return Perl_utf8_length(aTHX_ s, s + len);
4529 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4534 I32 uoffset = *offsetp;
4540 start = s = (U8*)SvPV(sv, len);
4542 while (s < send && uoffset--)
4546 *offsetp = s - start;
4550 while (s < send && ulen--)
4560 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4569 s = (U8*)SvPV(sv, len);
4571 Perl_croak(aTHX_ "panic: bad byte offset");
4572 send = s + *offsetp;
4579 if (ckWARN_d(WARN_UTF8))
4580 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4590 Returns a boolean indicating whether the strings in the two SVs are
4597 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4604 bool pv1tmp = FALSE;
4605 bool pv2tmp = FALSE;
4612 pv1 = SvPV(sv1, cur1);
4619 pv2 = SvPV(sv2, cur2);
4621 /* do not utf8ize the comparands as a side-effect */
4622 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4624 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4628 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4634 eq = memEQ(pv1, pv2, cur1);
4647 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4648 string in C<sv1> is less than, equal to, or greater than the string in
4655 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4660 bool pv1tmp = FALSE;
4661 bool pv2tmp = FALSE;
4668 pv1 = SvPV(sv1, cur1);
4675 pv2 = SvPV(sv2, cur2);
4677 /* do not utf8ize the comparands as a side-effect */
4678 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4680 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4684 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4690 cmp = cur2 ? -1 : 0;
4694 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4697 cmp = retval < 0 ? -1 : 1;
4698 } else if (cur1 == cur2) {
4701 cmp = cur1 < cur2 ? -1 : 1;
4714 =for apidoc sv_cmp_locale
4716 Compares the strings in two SVs in a locale-aware manner. See
4723 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4725 #ifdef USE_LOCALE_COLLATE
4731 if (PL_collation_standard)
4735 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4737 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4739 if (!pv1 || !len1) {
4750 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4753 return retval < 0 ? -1 : 1;
4756 * When the result of collation is equality, that doesn't mean
4757 * that there are no differences -- some locales exclude some
4758 * characters from consideration. So to avoid false equalities,
4759 * we use the raw string as a tiebreaker.
4765 #endif /* USE_LOCALE_COLLATE */
4767 return sv_cmp(sv1, sv2);
4770 #ifdef USE_LOCALE_COLLATE
4772 * Any scalar variable may carry an 'o' magic that contains the
4773 * scalar data of the variable transformed to such a format that
4774 * a normal memory comparison can be used to compare the data
4775 * according to the locale settings.
4778 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4782 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4783 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4788 Safefree(mg->mg_ptr);
4790 if ((xf = mem_collxfrm(s, len, &xlen))) {
4791 if (SvREADONLY(sv)) {
4794 return xf + sizeof(PL_collation_ix);
4797 sv_magic(sv, 0, 'o', 0, 0);
4798 mg = mg_find(sv, 'o');
4811 if (mg && mg->mg_ptr) {
4813 return mg->mg_ptr + sizeof(PL_collation_ix);
4821 #endif /* USE_LOCALE_COLLATE */
4826 Get a line from the filehandle and store it into the SV, optionally
4827 appending to the currently-stored string.
4833 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4837 register STDCHAR rslast;
4838 register STDCHAR *bp;
4842 SV_CHECK_THINKFIRST(sv);
4843 (void)SvUPGRADE(sv, SVt_PV);
4847 if (RsSNARF(PL_rs)) {
4851 else if (RsRECORD(PL_rs)) {
4852 I32 recsize, bytesread;
4855 /* Grab the size of the record we're getting */
4856 recsize = SvIV(SvRV(PL_rs));
4857 (void)SvPOK_only(sv); /* Validate pointer */
4858 buffer = SvGROW(sv, recsize + 1);
4861 /* VMS wants read instead of fread, because fread doesn't respect */
4862 /* RMS record boundaries. This is not necessarily a good thing to be */
4863 /* doing, but we've got no other real choice */
4864 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4866 bytesread = PerlIO_read(fp, buffer, recsize);
4868 SvCUR_set(sv, bytesread);
4869 buffer[bytesread] = '\0';
4870 if (PerlIO_isutf8(fp))
4874 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4876 else if (RsPARA(PL_rs)) {
4881 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4882 if (PerlIO_isutf8(fp)) {
4883 rsptr = SvPVutf8(PL_rs, rslen);
4886 if (SvUTF8(PL_rs)) {
4887 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4888 Perl_croak(aTHX_ "Wide character in $/");
4891 rsptr = SvPV(PL_rs, rslen);
4895 rslast = rslen ? rsptr[rslen - 1] : '\0';
4897 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4898 do { /* to make sure file boundaries work right */
4901 i = PerlIO_getc(fp);
4905 PerlIO_ungetc(fp,i);
4911 /* See if we know enough about I/O mechanism to cheat it ! */
4913 /* This used to be #ifdef test - it is made run-time test for ease
4914 of abstracting out stdio interface. One call should be cheap
4915 enough here - and may even be a macro allowing compile
4919 if (PerlIO_fast_gets(fp)) {
4922 * We're going to steal some values from the stdio struct
4923 * and put EVERYTHING in the innermost loop into registers.
4925 register STDCHAR *ptr;
4929 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4930 /* An ungetc()d char is handled separately from the regular
4931 * buffer, so we getc() it back out and stuff it in the buffer.
4933 i = PerlIO_getc(fp);
4934 if (i == EOF) return 0;
4935 *(--((*fp)->_ptr)) = (unsigned char) i;
4939 /* Here is some breathtakingly efficient cheating */
4941 cnt = PerlIO_get_cnt(fp); /* get count into register */
4942 (void)SvPOK_only(sv); /* validate pointer */
4943 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4944 if (cnt > 80 && SvLEN(sv) > append) {
4945 shortbuffered = cnt - SvLEN(sv) + append + 1;
4946 cnt -= shortbuffered;
4950 /* remember that cnt can be negative */
4951 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4956 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4957 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4958 DEBUG_P(PerlIO_printf(Perl_debug_log,
4959 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4960 DEBUG_P(PerlIO_printf(Perl_debug_log,
4961 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4962 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4963 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4968 while (cnt > 0) { /* this | eat */
4970 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4971 goto thats_all_folks; /* screams | sed :-) */
4975 Copy(ptr, bp, cnt, char); /* this | eat */
4976 bp += cnt; /* screams | dust */
4977 ptr += cnt; /* louder | sed :-) */
4982 if (shortbuffered) { /* oh well, must extend */
4983 cnt = shortbuffered;
4985 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4987 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4988 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4992 DEBUG_P(PerlIO_printf(Perl_debug_log,
4993 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4994 PTR2UV(ptr),(long)cnt));
4995 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4996 DEBUG_P(PerlIO_printf(Perl_debug_log,
4997 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4998 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4999 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5000 /* This used to call 'filbuf' in stdio form, but as that behaves like
5001 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5002 another abstraction. */
5003 i = PerlIO_getc(fp); /* get more characters */
5004 DEBUG_P(PerlIO_printf(Perl_debug_log,
5005 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5006 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5007 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5008 cnt = PerlIO_get_cnt(fp);
5009 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5010 DEBUG_P(PerlIO_printf(Perl_debug_log,
5011 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5013 if (i == EOF) /* all done for ever? */
5014 goto thats_really_all_folks;
5016 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5018 SvGROW(sv, bpx + cnt + 2);
5019 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5021 *bp++ = i; /* store character from PerlIO_getc */
5023 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5024 goto thats_all_folks;
5028 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5029 memNE((char*)bp - rslen, rsptr, rslen))
5030 goto screamer; /* go back to the fray */
5031 thats_really_all_folks:
5033 cnt += shortbuffered;
5034 DEBUG_P(PerlIO_printf(Perl_debug_log,
5035 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5036 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5037 DEBUG_P(PerlIO_printf(Perl_debug_log,
5038 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5039 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5040 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5042 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5043 DEBUG_P(PerlIO_printf(Perl_debug_log,
5044 "Screamer: done, len=%ld, string=|%.*s|\n",
5045 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5050 /*The big, slow, and stupid way */
5053 /* Need to work around EPOC SDK features */
5054 /* On WINS: MS VC5 generates calls to _chkstk, */
5055 /* if a `large' stack frame is allocated */
5056 /* gcc on MARM does not generate calls like these */
5062 register STDCHAR *bpe = buf + sizeof(buf);
5064 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5065 ; /* keep reading */
5069 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5070 /* Accomodate broken VAXC compiler, which applies U8 cast to
5071 * both args of ?: operator, causing EOF to change into 255
5073 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5077 sv_catpvn(sv, (char *) buf, cnt);
5079 sv_setpvn(sv, (char *) buf, cnt);
5081 if (i != EOF && /* joy */
5083 SvCUR(sv) < rslen ||
5084 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5088 * If we're reading from a TTY and we get a short read,
5089 * indicating that the user hit his EOF character, we need
5090 * to notice it now, because if we try to read from the TTY
5091 * again, the EOF condition will disappear.
5093 * The comparison of cnt to sizeof(buf) is an optimization
5094 * that prevents unnecessary calls to feof().
5098 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5103 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5104 while (i != EOF) { /* to make sure file boundaries work right */
5105 i = PerlIO_getc(fp);
5107 PerlIO_ungetc(fp,i);
5113 if (PerlIO_isutf8(fp))
5118 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5125 Auto-increment of the value in the SV.
5131 Perl_sv_inc(pTHX_ register SV *sv)
5140 if (SvTHINKFIRST(sv)) {
5141 if (SvREADONLY(sv)) {
5142 if (PL_curcop != &PL_compiling)
5143 Perl_croak(aTHX_ PL_no_modify);
5147 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5149 i = PTR2IV(SvRV(sv));
5154 flags = SvFLAGS(sv);
5155 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5156 /* It's (privately or publicly) a float, but not tested as an
5157 integer, so test it to see. */
5159 flags = SvFLAGS(sv);
5161 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5162 /* It's publicly an integer, or privately an integer-not-float */
5165 if (SvUVX(sv) == UV_MAX)
5166 sv_setnv(sv, (NV)UV_MAX + 1.0);
5168 (void)SvIOK_only_UV(sv);
5171 if (SvIVX(sv) == IV_MAX)
5172 sv_setuv(sv, (UV)IV_MAX + 1);
5174 (void)SvIOK_only(sv);
5180 if (flags & SVp_NOK) {
5181 (void)SvNOK_only(sv);
5186 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5187 if ((flags & SVTYPEMASK) < SVt_PVIV)
5188 sv_upgrade(sv, SVt_IV);
5189 (void)SvIOK_only(sv);
5194 while (isALPHA(*d)) d++;
5195 while (isDIGIT(*d)) d++;
5197 #ifdef PERL_PRESERVE_IVUV
5198 /* Got to punt this an an integer if needs be, but we don't issue
5199 warnings. Probably ought to make the sv_iv_please() that does
5200 the conversion if possible, and silently. */
5201 I32 numtype = looks_like_number(sv);
5202 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5203 /* Need to try really hard to see if it's an integer.
5204 9.22337203685478e+18 is an integer.
5205 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5206 so $a="9.22337203685478e+18"; $a+0; $a++
5207 needs to be the same as $a="9.22337203685478e+18"; $a++
5214 /* sv_2iv *should* have made this an NV */
5215 if (flags & SVp_NOK) {
5216 (void)SvNOK_only(sv);
5220 /* I don't think we can get here. Maybe I should assert this
5221 And if we do get here I suspect that sv_setnv will croak. NWC
5223 #if defined(USE_LONG_DOUBLE)
5224 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",
5225 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5227 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5228 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5231 #endif /* PERL_PRESERVE_IVUV */
5232 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5236 while (d >= SvPVX(sv)) {
5244 /* MKS: The original code here died if letters weren't consecutive.
5245 * at least it didn't have to worry about non-C locales. The
5246 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5247 * arranged in order (although not consecutively) and that only
5248 * [A-Za-z] are accepted by isALPHA in the C locale.
5250 if (*d != 'z' && *d != 'Z') {
5251 do { ++*d; } while (!isALPHA(*d));
5254 *(d--) -= 'z' - 'a';
5259 *(d--) -= 'z' - 'a' + 1;
5263 /* oh,oh, the number grew */
5264 SvGROW(sv, SvCUR(sv) + 2);
5266 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5277 Auto-decrement of the value in the SV.
5283 Perl_sv_dec(pTHX_ register SV *sv)
5291 if (SvTHINKFIRST(sv)) {
5292 if (SvREADONLY(sv)) {
5293 if (PL_curcop != &PL_compiling)
5294 Perl_croak(aTHX_ PL_no_modify);
5298 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5300 i = PTR2IV(SvRV(sv));
5305 /* Unlike sv_inc we don't have to worry about string-never-numbers
5306 and keeping them magic. But we mustn't warn on punting */
5307 flags = SvFLAGS(sv);
5308 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5309 /* It's publicly an integer, or privately an integer-not-float */
5312 if (SvUVX(sv) == 0) {
5313 (void)SvIOK_only(sv);
5317 (void)SvIOK_only_UV(sv);
5321 if (SvIVX(sv) == IV_MIN)
5322 sv_setnv(sv, (NV)IV_MIN - 1.0);
5324 (void)SvIOK_only(sv);
5330 if (flags & SVp_NOK) {
5332 (void)SvNOK_only(sv);
5335 if (!(flags & SVp_POK)) {
5336 if ((flags & SVTYPEMASK) < SVt_PVNV)
5337 sv_upgrade(sv, SVt_NV);
5339 (void)SvNOK_only(sv);
5342 #ifdef PERL_PRESERVE_IVUV
5344 I32 numtype = looks_like_number(sv);
5345 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5346 /* Need to try really hard to see if it's an integer.
5347 9.22337203685478e+18 is an integer.
5348 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5349 so $a="9.22337203685478e+18"; $a+0; $a--
5350 needs to be the same as $a="9.22337203685478e+18"; $a--
5357 /* sv_2iv *should* have made this an NV */
5358 if (flags & SVp_NOK) {
5359 (void)SvNOK_only(sv);
5363 /* I don't think we can get here. Maybe I should assert this
5364 And if we do get here I suspect that sv_setnv will croak. NWC
5366 #if defined(USE_LONG_DOUBLE)
5367 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",
5368 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5370 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5371 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5375 #endif /* PERL_PRESERVE_IVUV */
5376 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5380 =for apidoc sv_mortalcopy
5382 Creates a new SV which is a copy of the original SV. The new SV is marked
5388 /* Make a string that will exist for the duration of the expression
5389 * evaluation. Actually, it may have to last longer than that, but
5390 * hopefully we won't free it until it has been assigned to a
5391 * permanent location. */
5394 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5399 sv_setsv(sv,oldstr);
5401 PL_tmps_stack[++PL_tmps_ix] = sv;
5407 =for apidoc sv_newmortal
5409 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5415 Perl_sv_newmortal(pTHX)
5420 SvFLAGS(sv) = SVs_TEMP;
5422 PL_tmps_stack[++PL_tmps_ix] = sv;
5427 =for apidoc sv_2mortal
5429 Marks an SV as mortal. The SV will be destroyed when the current context
5435 /* same thing without the copying */
5438 Perl_sv_2mortal(pTHX_ register SV *sv)
5442 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5445 PL_tmps_stack[++PL_tmps_ix] = sv;
5453 Creates a new SV and copies a string into it. The reference count for the
5454 SV is set to 1. If C<len> is zero, Perl will compute the length using
5455 strlen(). For efficiency, consider using C<newSVpvn> instead.
5461 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5468 sv_setpvn(sv,s,len);
5473 =for apidoc newSVpvn
5475 Creates a new SV and copies a string into it. The reference count for the
5476 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5477 string. You are responsible for ensuring that the source string is at least
5484 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5489 sv_setpvn(sv,s,len);
5494 =for apidoc newSVpvn_share
5496 Creates a new SV and populates it with a string from
5497 the string table. Turns on READONLY and FAKE.
5498 The idea here is that as string table is used for shared hash
5499 keys these strings will have SvPVX == HeKEY and hash lookup
5500 will avoid string compare.
5506 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5509 bool is_utf8 = FALSE;
5515 PERL_HASH(hash, src, len);
5517 sv_upgrade(sv, SVt_PVIV);
5518 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5530 #if defined(PERL_IMPLICIT_CONTEXT)
5532 Perl_newSVpvf_nocontext(const char* pat, ...)
5537 va_start(args, pat);
5538 sv = vnewSVpvf(pat, &args);
5545 =for apidoc newSVpvf
5547 Creates a new SV an initialize it with the string formatted like
5554 Perl_newSVpvf(pTHX_ const char* pat, ...)
5558 va_start(args, pat);
5559 sv = vnewSVpvf(pat, &args);
5565 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5569 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5576 Creates a new SV and copies a floating point value into it.
5577 The reference count for the SV is set to 1.
5583 Perl_newSVnv(pTHX_ NV n)
5595 Creates a new SV and copies an integer into it. The reference count for the
5602 Perl_newSViv(pTHX_ IV i)
5614 Creates a new SV and copies an unsigned integer into it.
5615 The reference count for the SV is set to 1.
5621 Perl_newSVuv(pTHX_ UV u)
5631 =for apidoc newRV_noinc
5633 Creates an RV wrapper for an SV. The reference count for the original
5634 SV is B<not> incremented.
5640 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5645 sv_upgrade(sv, SVt_RV);
5652 /* newRV_inc is #defined to newRV in sv.h */
5654 Perl_newRV(pTHX_ SV *tmpRef)
5656 return newRV_noinc(SvREFCNT_inc(tmpRef));
5662 Creates a new SV which is an exact duplicate of the original SV.
5667 /* make an exact duplicate of old */
5670 Perl_newSVsv(pTHX_ register SV *old)
5676 if (SvTYPE(old) == SVTYPEMASK) {
5677 if (ckWARN_d(WARN_INTERNAL))
5678 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5693 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5701 char todo[PERL_UCHAR_MAX+1];
5706 if (!*s) { /* reset ?? searches */
5707 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5708 pm->op_pmdynflags &= ~PMdf_USED;
5713 /* reset variables */
5715 if (!HvARRAY(stash))
5718 Zero(todo, 256, char);
5720 i = (unsigned char)*s;
5724 max = (unsigned char)*s++;
5725 for ( ; i <= max; i++) {
5728 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5729 for (entry = HvARRAY(stash)[i];
5731 entry = HeNEXT(entry))
5733 if (!todo[(U8)*HeKEY(entry)])
5735 gv = (GV*)HeVAL(entry);
5737 if (SvTHINKFIRST(sv)) {
5738 if (!SvREADONLY(sv) && SvROK(sv))
5743 if (SvTYPE(sv) >= SVt_PV) {
5745 if (SvPVX(sv) != Nullch)
5752 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5754 #ifdef USE_ENVIRON_ARRAY
5756 environ[0] = Nullch;
5765 Perl_sv_2io(pTHX_ SV *sv)
5771 switch (SvTYPE(sv)) {
5779 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5783 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5785 return sv_2io(SvRV(sv));
5786 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5792 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5799 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5806 return *gvp = Nullgv, Nullcv;
5807 switch (SvTYPE(sv)) {
5826 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5827 tryAMAGICunDEREF(to_cv);
5830 if (SvTYPE(sv) == SVt_PVCV) {
5839 Perl_croak(aTHX_ "Not a subroutine reference");
5844 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5850 if (lref && !GvCVu(gv)) {
5853 tmpsv = NEWSV(704,0);
5854 gv_efullname3(tmpsv, gv, Nullch);
5855 /* XXX this is probably not what they think they're getting.
5856 * It has the same effect as "sub name;", i.e. just a forward
5858 newSUB(start_subparse(FALSE, 0),
5859 newSVOP(OP_CONST, 0, tmpsv),
5864 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5873 Returns true if the SV has a true value by Perl's rules.
5879 Perl_sv_true(pTHX_ register SV *sv)
5885 if ((tXpv = (XPV*)SvANY(sv)) &&
5886 (tXpv->xpv_cur > 1 ||
5887 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5894 return SvIVX(sv) != 0;
5897 return SvNVX(sv) != 0.0;
5899 return sv_2bool(sv);
5905 Perl_sv_iv(pTHX_ register SV *sv)
5909 return (IV)SvUVX(sv);
5916 Perl_sv_uv(pTHX_ register SV *sv)
5921 return (UV)SvIVX(sv);
5927 Perl_sv_nv(pTHX_ register SV *sv)
5935 Perl_sv_pv(pTHX_ SV *sv)
5942 return sv_2pv(sv, &n_a);
5946 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5952 return sv_2pv(sv, lp);
5956 =for apidoc sv_pvn_force
5958 Get a sensible string out of the SV somehow.
5964 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5968 if (SvTHINKFIRST(sv) && !SvROK(sv))
5969 sv_force_normal(sv);
5975 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5976 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5977 PL_op_name[PL_op->op_type]);
5981 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5986 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5987 SvGROW(sv, len + 1);
5988 Move(s,SvPVX(sv),len,char);
5993 SvPOK_on(sv); /* validate pointer */
5995 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5996 PTR2UV(sv),SvPVX(sv)));
6003 Perl_sv_pvbyte(pTHX_ SV *sv)
6009 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6011 return sv_pvn(sv,lp);
6015 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6017 return sv_pvn_force(sv,lp);
6021 Perl_sv_pvutf8(pTHX_ SV *sv)
6023 sv_utf8_upgrade(sv);
6028 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6030 sv_utf8_upgrade(sv);
6031 return sv_pvn(sv,lp);
6035 =for apidoc sv_pvutf8n_force
6037 Get a sensible UTF8-encoded string out of the SV somehow. See
6044 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6046 sv_utf8_upgrade(sv);
6047 return sv_pvn_force(sv,lp);
6051 =for apidoc sv_reftype
6053 Returns a string describing what the SV is a reference to.
6059 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6061 if (ob && SvOBJECT(sv))
6062 return HvNAME(SvSTASH(sv));
6064 switch (SvTYPE(sv)) {
6078 case SVt_PVLV: return "LVALUE";
6079 case SVt_PVAV: return "ARRAY";
6080 case SVt_PVHV: return "HASH";
6081 case SVt_PVCV: return "CODE";
6082 case SVt_PVGV: return "GLOB";
6083 case SVt_PVFM: return "FORMAT";
6084 case SVt_PVIO: return "IO";
6085 default: return "UNKNOWN";
6091 =for apidoc sv_isobject
6093 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6094 object. If the SV is not an RV, or if the object is not blessed, then this
6101 Perl_sv_isobject(pTHX_ SV *sv)
6118 Returns a boolean indicating whether the SV is blessed into the specified
6119 class. This does not check for subtypes; use C<sv_derived_from> to verify
6120 an inheritance relationship.
6126 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6138 return strEQ(HvNAME(SvSTASH(sv)), name);
6144 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6145 it will be upgraded to one. If C<classname> is non-null then the new SV will
6146 be blessed in the specified package. The new SV is returned and its
6147 reference count is 1.
6153 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6159 SV_CHECK_THINKFIRST(rv);
6162 if (SvTYPE(rv) >= SVt_PVMG) {
6163 U32 refcnt = SvREFCNT(rv);
6167 SvREFCNT(rv) = refcnt;
6170 if (SvTYPE(rv) < SVt_RV)
6171 sv_upgrade(rv, SVt_RV);
6172 else if (SvTYPE(rv) > SVt_RV) {
6173 (void)SvOOK_off(rv);
6174 if (SvPVX(rv) && SvLEN(rv))
6175 Safefree(SvPVX(rv));
6185 HV* stash = gv_stashpv(classname, TRUE);
6186 (void)sv_bless(rv, stash);
6192 =for apidoc sv_setref_pv
6194 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6195 argument will be upgraded to an RV. That RV will be modified to point to
6196 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6197 into the SV. The C<classname> argument indicates the package for the
6198 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6199 will be returned and will have a reference count of 1.
6201 Do not use with other Perl types such as HV, AV, SV, CV, because those
6202 objects will become corrupted by the pointer copy process.
6204 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6210 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6213 sv_setsv(rv, &PL_sv_undef);
6217 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6222 =for apidoc sv_setref_iv
6224 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6225 argument will be upgraded to an RV. That RV will be modified to point to
6226 the new SV. The C<classname> argument indicates the package for the
6227 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6228 will be returned and will have a reference count of 1.
6234 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6236 sv_setiv(newSVrv(rv,classname), iv);
6241 =for apidoc sv_setref_nv
6243 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6244 argument will be upgraded to an RV. That RV will be modified to point to
6245 the new SV. The C<classname> argument indicates the package for the
6246 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6247 will be returned and will have a reference count of 1.
6253 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6255 sv_setnv(newSVrv(rv,classname), nv);
6260 =for apidoc sv_setref_pvn
6262 Copies a string into a new SV, optionally blessing the SV. The length of the
6263 string must be specified with C<n>. The C<rv> argument will be upgraded to
6264 an RV. That RV will be modified to point to the new SV. The C<classname>
6265 argument indicates the package for the blessing. Set C<classname> to
6266 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6267 a reference count of 1.
6269 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6275 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6277 sv_setpvn(newSVrv(rv,classname), pv, n);
6282 =for apidoc sv_bless
6284 Blesses an SV into a specified package. The SV must be an RV. The package
6285 must be designated by its stash (see C<gv_stashpv()>). The reference count
6286 of the SV is unaffected.
6292 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6296 Perl_croak(aTHX_ "Can't bless non-reference value");
6298 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6299 if (SvREADONLY(tmpRef))
6300 Perl_croak(aTHX_ PL_no_modify);
6301 if (SvOBJECT(tmpRef)) {
6302 if (SvTYPE(tmpRef) != SVt_PVIO)
6304 SvREFCNT_dec(SvSTASH(tmpRef));
6307 SvOBJECT_on(tmpRef);
6308 if (SvTYPE(tmpRef) != SVt_PVIO)
6310 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6311 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6322 S_sv_unglob(pTHX_ SV *sv)
6326 assert(SvTYPE(sv) == SVt_PVGV);
6331 SvREFCNT_dec(GvSTASH(sv));
6332 GvSTASH(sv) = Nullhv;
6334 sv_unmagic(sv, '*');
6335 Safefree(GvNAME(sv));
6338 /* need to keep SvANY(sv) in the right arena */
6339 xpvmg = new_XPVMG();
6340 StructCopy(SvANY(sv), xpvmg, XPVMG);
6341 del_XPVGV(SvANY(sv));
6344 SvFLAGS(sv) &= ~SVTYPEMASK;
6345 SvFLAGS(sv) |= SVt_PVMG;
6349 =for apidoc sv_unref_flags
6351 Unsets the RV status of the SV, and decrements the reference count of
6352 whatever was being referenced by the RV. This can almost be thought of
6353 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6354 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6355 (otherwise the decrementing is conditional on the reference count being
6356 different from one or the reference being a readonly SV).
6363 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6367 if (SvWEAKREF(sv)) {
6375 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6377 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6378 sv_2mortal(rv); /* Schedule for freeing later */
6382 =for apidoc sv_unref
6384 Unsets the RV status of the SV, and decrements the reference count of
6385 whatever was being referenced by the RV. This can almost be thought of
6386 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6387 being zero. See C<SvROK_off>.
6393 Perl_sv_unref(pTHX_ SV *sv)
6395 sv_unref_flags(sv, 0);
6399 Perl_sv_taint(pTHX_ SV *sv)
6401 sv_magic((sv), Nullsv, 't', Nullch, 0);
6405 Perl_sv_untaint(pTHX_ SV *sv)
6407 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6408 MAGIC *mg = mg_find(sv, 't');
6415 Perl_sv_tainted(pTHX_ SV *sv)
6417 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6418 MAGIC *mg = mg_find(sv, 't');
6419 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6426 =for apidoc sv_setpviv
6428 Copies an integer into the given SV, also updating its string value.
6429 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6435 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6437 char buf[TYPE_CHARS(UV)];
6439 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6441 sv_setpvn(sv, ptr, ebuf - ptr);
6446 =for apidoc sv_setpviv_mg
6448 Like C<sv_setpviv>, but also handles 'set' magic.
6454 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6456 char buf[TYPE_CHARS(UV)];
6458 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6460 sv_setpvn(sv, ptr, ebuf - ptr);
6464 #if defined(PERL_IMPLICIT_CONTEXT)
6466 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6470 va_start(args, pat);
6471 sv_vsetpvf(sv, pat, &args);
6477 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6481 va_start(args, pat);
6482 sv_vsetpvf_mg(sv, pat, &args);
6488 =for apidoc sv_setpvf
6490 Processes its arguments like C<sprintf> and sets an SV to the formatted
6491 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6497 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6500 va_start(args, pat);
6501 sv_vsetpvf(sv, pat, &args);
6506 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6508 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6512 =for apidoc sv_setpvf_mg
6514 Like C<sv_setpvf>, but also handles 'set' magic.
6520 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6523 va_start(args, pat);
6524 sv_vsetpvf_mg(sv, pat, &args);
6529 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6531 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6535 #if defined(PERL_IMPLICIT_CONTEXT)
6537 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6541 va_start(args, pat);
6542 sv_vcatpvf(sv, pat, &args);
6547 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6551 va_start(args, pat);
6552 sv_vcatpvf_mg(sv, pat, &args);
6558 =for apidoc sv_catpvf
6560 Processes its arguments like C<sprintf> and appends the formatted output
6561 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6562 typically be called after calling this function to handle 'set' magic.
6568 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6571 va_start(args, pat);
6572 sv_vcatpvf(sv, pat, &args);
6577 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6579 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6583 =for apidoc sv_catpvf_mg
6585 Like C<sv_catpvf>, but also handles 'set' magic.
6591 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6594 va_start(args, pat);
6595 sv_vcatpvf_mg(sv, pat, &args);
6600 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6602 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6607 =for apidoc sv_vsetpvfn
6609 Works like C<vcatpvfn> but copies the text into the SV instead of
6616 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6618 sv_setpvn(sv, "", 0);
6619 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6623 =for apidoc sv_vcatpvfn
6625 Processes its arguments like C<vsprintf> and appends the formatted output
6626 to an SV. Uses an array of SVs if the C style variable argument list is
6627 missing (NULL). When running with taint checks enabled, indicates via
6628 C<maybe_tainted> if results are untrustworthy (often due to the use of
6635 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6642 static char nullstr[] = "(null)";
6645 /* no matter what, this is a string now */
6646 (void)SvPV_force(sv, origlen);
6648 /* special-case "", "%s", and "%_" */
6651 if (patlen == 2 && pat[0] == '%') {
6655 char *s = va_arg(*args, char*);
6656 sv_catpv(sv, s ? s : nullstr);
6658 else if (svix < svmax) {
6659 sv_catsv(sv, *svargs);
6660 if (DO_UTF8(*svargs))
6666 argsv = va_arg(*args, SV*);
6667 sv_catsv(sv, argsv);
6672 /* See comment on '_' below */
6677 patend = (char*)pat + patlen;
6678 for (p = (char*)pat; p < patend; p = q) {
6681 bool vectorize = FALSE;
6688 bool has_precis = FALSE;
6690 bool is_utf = FALSE;
6693 U8 utf8buf[UTF8_MAXLEN+1];
6694 STRLEN esignlen = 0;
6696 char *eptr = Nullch;
6698 /* Times 4: a decimal digit takes more than 3 binary digits.
6699 * NV_DIG: mantissa takes than many decimal digits.
6700 * Plus 32: Playing safe. */
6701 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6702 /* large enough for "%#.#f" --chip */
6703 /* what about long double NVs? --jhi */
6706 U8 *vecstr = Null(U8*);
6718 STRLEN dotstrlen = 1;
6719 I32 epix = 0; /* explicit parameter index */
6720 I32 ewix = 0; /* explicit width index */
6721 bool asterisk = FALSE;
6723 for (q = p; q < patend && *q != '%'; ++q) ;
6725 sv_catpvn(sv, p, q - p);
6754 case '*': /* printf("%*vX",":",$ipv6addr) */
6759 vecsv = va_arg(*args, SV*);
6760 else if (svix < svmax)
6761 vecsv = svargs[svix++];
6764 dotstr = SvPVx(vecsv,dotstrlen);
6792 case '1': case '2': case '3':
6793 case '4': case '5': case '6':
6794 case '7': case '8': case '9':
6797 width = width * 10 + (*q++ - '0');
6799 if (asterisk && ewix == 0) {
6804 } else if (epix == 0) {
6816 i = va_arg(*args, int);
6818 i = (ewix ? ewix <= svmax : svix < svmax) ?
6819 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6821 width = (i < 0) ? -i : i;
6830 i = va_arg(*args, int);
6832 i = (ewix ? ewix <= svmax : svix < svmax)
6833 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6834 precis = (i < 0) ? 0 : i;
6840 precis = precis * 10 + (*q++ - '0');
6847 vecsv = va_arg(*args, SV*);
6848 vecstr = (U8*)SvPVx(vecsv,veclen);
6849 utf = DO_UTF8(vecsv);
6851 else if (epix ? epix <= svmax : svix < svmax) {
6852 vecsv = svargs[epix ? epix-1 : svix++];
6853 vecstr = (U8*)SvPVx(vecsv,veclen);
6854 utf = DO_UTF8(vecsv);
6865 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6876 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6877 if (*(q + 1) == 'l') { /* lld, llf */
6904 uv = va_arg(*args, int);
6906 uv = (epix ? epix <= svmax : svix < svmax) ?
6907 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6908 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6909 eptr = (char*)utf8buf;
6910 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6922 eptr = va_arg(*args, char*);
6924 #ifdef MACOS_TRADITIONAL
6925 /* On MacOS, %#s format is used for Pascal strings */
6930 elen = strlen(eptr);
6933 elen = sizeof nullstr - 1;
6936 else if (epix ? epix <= svmax : svix < svmax) {
6937 argsv = svargs[epix ? epix-1 : svix++];
6938 eptr = SvPVx(argsv, elen);
6939 if (DO_UTF8(argsv)) {
6940 if (has_precis && precis < elen) {
6942 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6945 if (width) { /* fudge width (can't fudge elen) */
6946 width += elen - sv_len_utf8(argsv);
6955 * The "%_" hack might have to be changed someday,
6956 * if ISO or ANSI decide to use '_' for something.
6957 * So we keep it hidden from users' code.
6961 argsv = va_arg(*args,SV*);
6962 eptr = SvPVx(argsv, elen);
6968 if (has_precis && elen > precis)
6978 uv = PTR2UV(va_arg(*args, void*));
6980 uv = (epix ? epix <= svmax : svix < svmax) ?
6981 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
7001 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7011 case 'h': iv = (short)va_arg(*args, int); break;
7012 default: iv = va_arg(*args, int); break;
7013 case 'l': iv = va_arg(*args, long); break;
7014 case 'V': iv = va_arg(*args, IV); break;
7016 case 'q': iv = va_arg(*args, Quad_t); break;
7021 iv = (epix ? epix <= svmax : svix < svmax) ?
7022 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
7024 case 'h': iv = (short)iv; break;
7026 case 'l': iv = (long)iv; break;
7029 case 'q': iv = (Quad_t)iv; break;
7036 esignbuf[esignlen++] = plus;
7040 esignbuf[esignlen++] = '-';
7084 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7094 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7095 default: uv = va_arg(*args, unsigned); break;
7096 case 'l': uv = va_arg(*args, unsigned long); break;
7097 case 'V': uv = va_arg(*args, UV); break;
7099 case 'q': uv = va_arg(*args, Quad_t); break;
7104 uv = (epix ? epix <= svmax : svix < svmax) ?
7105 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
7107 case 'h': uv = (unsigned short)uv; break;
7109 case 'l': uv = (unsigned long)uv; break;
7112 case 'q': uv = (Quad_t)uv; break;
7118 eptr = ebuf + sizeof ebuf;
7124 p = (char*)((c == 'X')
7125 ? "0123456789ABCDEF" : "0123456789abcdef");
7131 esignbuf[esignlen++] = '0';
7132 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7138 *--eptr = '0' + dig;
7140 if (alt && *eptr != '0')
7146 *--eptr = '0' + dig;
7149 esignbuf[esignlen++] = '0';
7150 esignbuf[esignlen++] = 'b';
7153 default: /* it had better be ten or less */
7154 #if defined(PERL_Y2KWARN)
7155 if (ckWARN(WARN_Y2K)) {
7157 char *s = SvPV(sv,n);
7158 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7159 && (n == 2 || !isDIGIT(s[n-3])))
7161 Perl_warner(aTHX_ WARN_Y2K,
7162 "Possible Y2K bug: %%%c %s",
7163 c, "format string following '19'");
7169 *--eptr = '0' + dig;
7170 } while (uv /= base);
7173 elen = (ebuf + sizeof ebuf) - eptr;
7176 zeros = precis - elen;
7177 else if (precis == 0 && elen == 1 && *eptr == '0')
7182 /* FLOATING POINT */
7185 c = 'f'; /* maybe %F isn't supported here */
7191 /* This is evil, but floating point is even more evil */
7195 nv = va_arg(*args, NV);
7197 nv = (epix ? epix <= svmax : svix < svmax) ?
7198 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
7201 if (c != 'e' && c != 'E') {
7203 (void)Perl_frexp(nv, &i);
7204 if (i == PERL_INT_MIN)
7205 Perl_die(aTHX_ "panic: frexp");
7207 need = BIT_DIGITS(i);
7209 need += has_precis ? precis : 6; /* known default */
7213 need += 20; /* fudge factor */
7214 if (PL_efloatsize < need) {
7215 Safefree(PL_efloatbuf);
7216 PL_efloatsize = need + 20; /* more fudge */
7217 New(906, PL_efloatbuf, PL_efloatsize, char);
7218 PL_efloatbuf[0] = '\0';
7221 eptr = ebuf + sizeof ebuf;
7224 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7226 /* Copy the one or more characters in a long double
7227 * format before the 'base' ([efgEFG]) character to
7228 * the format string. */
7229 static char const prifldbl[] = PERL_PRIfldbl;
7230 char const *p = prifldbl + sizeof(prifldbl) - 3;
7231 while (p >= prifldbl) { *--eptr = *p--; }
7236 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7241 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7253 /* No taint. Otherwise we are in the strange situation
7254 * where printf() taints but print($float) doesn't.
7256 (void)sprintf(PL_efloatbuf, eptr, nv);
7258 eptr = PL_efloatbuf;
7259 elen = strlen(PL_efloatbuf);
7266 i = SvCUR(sv) - origlen;
7269 case 'h': *(va_arg(*args, short*)) = i; break;
7270 default: *(va_arg(*args, int*)) = i; break;
7271 case 'l': *(va_arg(*args, long*)) = i; break;
7272 case 'V': *(va_arg(*args, IV*)) = i; break;
7274 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7278 else if (epix ? epix <= svmax : svix < svmax)
7279 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
7280 continue; /* not "break" */
7287 if (!args && ckWARN(WARN_PRINTF) &&
7288 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7289 SV *msg = sv_newmortal();
7290 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7291 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7294 Perl_sv_catpvf(aTHX_ msg,
7295 "\"%%%c\"", c & 0xFF);
7297 Perl_sv_catpvf(aTHX_ msg,
7298 "\"%%\\%03"UVof"\"",
7301 sv_catpv(msg, "end of string");
7302 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7305 /* output mangled stuff ... */
7311 /* ... right here, because formatting flags should not apply */
7312 SvGROW(sv, SvCUR(sv) + elen + 1);
7314 memcpy(p, eptr, elen);
7317 SvCUR(sv) = p - SvPVX(sv);
7318 continue; /* not "break" */
7321 have = esignlen + zeros + elen;
7322 need = (have > width ? have : width);
7325 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7327 if (esignlen && fill == '0') {
7328 for (i = 0; i < esignlen; i++)
7332 memset(p, fill, gap);
7335 if (esignlen && fill != '0') {
7336 for (i = 0; i < esignlen; i++)
7340 for (i = zeros; i; i--)
7344 memcpy(p, eptr, elen);
7348 memset(p, ' ', gap);
7353 memcpy(p, dotstr, dotstrlen);
7357 vectorize = FALSE; /* done iterating over vecstr */
7362 SvCUR(sv) = p - SvPVX(sv);
7370 #if defined(USE_ITHREADS)
7372 #if defined(USE_THREADS)
7373 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7376 #ifndef GpREFCNT_inc
7377 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7381 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7382 #define av_dup(s) (AV*)sv_dup((SV*)s)
7383 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7384 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7385 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7386 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7387 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7388 #define io_dup(s) (IO*)sv_dup((SV*)s)
7389 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7390 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7391 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7392 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7393 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7396 Perl_re_dup(pTHX_ REGEXP *r)
7398 /* XXX fix when pmop->op_pmregexp becomes shared */
7399 return ReREFCNT_inc(r);
7403 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7407 return (PerlIO*)NULL;
7409 /* look for it in the table first */
7410 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7414 /* create anew and remember what it is */
7415 ret = PerlIO_fdupopen(aTHX_ fp);
7416 ptr_table_store(PL_ptr_table, fp, ret);
7421 Perl_dirp_dup(pTHX_ DIR *dp)
7430 Perl_gp_dup(pTHX_ GP *gp)
7435 /* look for it in the table first */
7436 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7440 /* create anew and remember what it is */
7441 Newz(0, ret, 1, GP);
7442 ptr_table_store(PL_ptr_table, gp, ret);
7445 ret->gp_refcnt = 0; /* must be before any other dups! */
7446 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7447 ret->gp_io = io_dup_inc(gp->gp_io);
7448 ret->gp_form = cv_dup_inc(gp->gp_form);
7449 ret->gp_av = av_dup_inc(gp->gp_av);
7450 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7451 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7452 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7453 ret->gp_cvgen = gp->gp_cvgen;
7454 ret->gp_flags = gp->gp_flags;
7455 ret->gp_line = gp->gp_line;
7456 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7461 Perl_mg_dup(pTHX_ MAGIC *mg)
7463 MAGIC *mgret = (MAGIC*)NULL;
7466 return (MAGIC*)NULL;
7467 /* look for it in the table first */
7468 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7472 for (; mg; mg = mg->mg_moremagic) {
7474 Newz(0, nmg, 1, MAGIC);
7478 mgprev->mg_moremagic = nmg;
7479 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7480 nmg->mg_private = mg->mg_private;
7481 nmg->mg_type = mg->mg_type;
7482 nmg->mg_flags = mg->mg_flags;
7483 if (mg->mg_type == 'r') {
7484 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7487 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7488 ? sv_dup_inc(mg->mg_obj)
7489 : sv_dup(mg->mg_obj);
7491 nmg->mg_len = mg->mg_len;
7492 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7493 if (mg->mg_ptr && mg->mg_type != 'g') {
7494 if (mg->mg_len >= 0) {
7495 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7496 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7497 AMT *amtp = (AMT*)mg->mg_ptr;
7498 AMT *namtp = (AMT*)nmg->mg_ptr;
7500 for (i = 1; i < NofAMmeth; i++) {
7501 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7505 else if (mg->mg_len == HEf_SVKEY)
7506 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7514 Perl_ptr_table_new(pTHX)
7517 Newz(0, tbl, 1, PTR_TBL_t);
7520 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7525 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7527 PTR_TBL_ENT_t *tblent;
7528 UV hash = PTR2UV(sv);
7530 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7531 for (; tblent; tblent = tblent->next) {
7532 if (tblent->oldval == sv)
7533 return tblent->newval;
7539 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7541 PTR_TBL_ENT_t *tblent, **otblent;
7542 /* XXX this may be pessimal on platforms where pointers aren't good
7543 * hash values e.g. if they grow faster in the most significant
7545 UV hash = PTR2UV(oldv);
7549 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7550 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7551 if (tblent->oldval == oldv) {
7552 tblent->newval = newv;
7557 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7558 tblent->oldval = oldv;
7559 tblent->newval = newv;
7560 tblent->next = *otblent;
7563 if (i && tbl->tbl_items > tbl->tbl_max)
7564 ptr_table_split(tbl);
7568 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7570 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7571 UV oldsize = tbl->tbl_max + 1;
7572 UV newsize = oldsize * 2;
7575 Renew(ary, newsize, PTR_TBL_ENT_t*);
7576 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7577 tbl->tbl_max = --newsize;
7579 for (i=0; i < oldsize; i++, ary++) {
7580 PTR_TBL_ENT_t **curentp, **entp, *ent;
7583 curentp = ary + oldsize;
7584 for (entp = ary, ent = *ary; ent; ent = *entp) {
7585 if ((newsize & PTR2UV(ent->oldval)) != i) {
7587 ent->next = *curentp;
7602 Perl_sv_dup(pTHX_ SV *sstr)
7606 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7608 /* look for it in the table first */
7609 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7613 /* create anew and remember what it is */
7615 ptr_table_store(PL_ptr_table, sstr, dstr);
7618 SvFLAGS(dstr) = SvFLAGS(sstr);
7619 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7620 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7623 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7624 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7625 PL_watch_pvx, SvPVX(sstr));
7628 switch (SvTYPE(sstr)) {
7633 SvANY(dstr) = new_XIV();
7634 SvIVX(dstr) = SvIVX(sstr);
7637 SvANY(dstr) = new_XNV();
7638 SvNVX(dstr) = SvNVX(sstr);
7641 SvANY(dstr) = new_XRV();
7642 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7645 SvANY(dstr) = new_XPV();
7646 SvCUR(dstr) = SvCUR(sstr);
7647 SvLEN(dstr) = SvLEN(sstr);
7649 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7650 else if (SvPVX(sstr) && SvLEN(sstr))
7651 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7653 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7656 SvANY(dstr) = new_XPVIV();
7657 SvCUR(dstr) = SvCUR(sstr);
7658 SvLEN(dstr) = SvLEN(sstr);
7659 SvIVX(dstr) = SvIVX(sstr);
7661 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7662 else if (SvPVX(sstr) && SvLEN(sstr))
7663 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7665 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7668 SvANY(dstr) = new_XPVNV();
7669 SvCUR(dstr) = SvCUR(sstr);
7670 SvLEN(dstr) = SvLEN(sstr);
7671 SvIVX(dstr) = SvIVX(sstr);
7672 SvNVX(dstr) = SvNVX(sstr);
7674 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7675 else if (SvPVX(sstr) && SvLEN(sstr))
7676 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7678 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7681 SvANY(dstr) = new_XPVMG();
7682 SvCUR(dstr) = SvCUR(sstr);
7683 SvLEN(dstr) = SvLEN(sstr);
7684 SvIVX(dstr) = SvIVX(sstr);
7685 SvNVX(dstr) = SvNVX(sstr);
7686 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7687 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7689 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7690 else if (SvPVX(sstr) && SvLEN(sstr))
7691 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7693 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7696 SvANY(dstr) = new_XPVBM();
7697 SvCUR(dstr) = SvCUR(sstr);
7698 SvLEN(dstr) = SvLEN(sstr);
7699 SvIVX(dstr) = SvIVX(sstr);
7700 SvNVX(dstr) = SvNVX(sstr);
7701 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7702 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7704 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7705 else if (SvPVX(sstr) && SvLEN(sstr))
7706 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7708 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7709 BmRARE(dstr) = BmRARE(sstr);
7710 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7711 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7714 SvANY(dstr) = new_XPVLV();
7715 SvCUR(dstr) = SvCUR(sstr);
7716 SvLEN(dstr) = SvLEN(sstr);
7717 SvIVX(dstr) = SvIVX(sstr);
7718 SvNVX(dstr) = SvNVX(sstr);
7719 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7720 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7722 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7723 else if (SvPVX(sstr) && SvLEN(sstr))
7724 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7726 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7727 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7728 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7729 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7730 LvTYPE(dstr) = LvTYPE(sstr);
7733 SvANY(dstr) = new_XPVGV();
7734 SvCUR(dstr) = SvCUR(sstr);
7735 SvLEN(dstr) = SvLEN(sstr);
7736 SvIVX(dstr) = SvIVX(sstr);
7737 SvNVX(dstr) = SvNVX(sstr);
7738 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7739 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7741 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7742 else if (SvPVX(sstr) && SvLEN(sstr))
7743 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7745 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7746 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7747 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7748 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7749 GvFLAGS(dstr) = GvFLAGS(sstr);
7750 GvGP(dstr) = gp_dup(GvGP(sstr));
7751 (void)GpREFCNT_inc(GvGP(dstr));
7754 SvANY(dstr) = new_XPVIO();
7755 SvCUR(dstr) = SvCUR(sstr);
7756 SvLEN(dstr) = SvLEN(sstr);
7757 SvIVX(dstr) = SvIVX(sstr);
7758 SvNVX(dstr) = SvNVX(sstr);
7759 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7760 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7762 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7763 else if (SvPVX(sstr) && SvLEN(sstr))
7764 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7766 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7767 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7768 if (IoOFP(sstr) == IoIFP(sstr))
7769 IoOFP(dstr) = IoIFP(dstr);
7771 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7772 /* PL_rsfp_filters entries have fake IoDIRP() */
7773 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7774 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7776 IoDIRP(dstr) = IoDIRP(sstr);
7777 IoLINES(dstr) = IoLINES(sstr);
7778 IoPAGE(dstr) = IoPAGE(sstr);
7779 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7780 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7781 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7782 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7783 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7784 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7785 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7786 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7787 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7788 IoTYPE(dstr) = IoTYPE(sstr);
7789 IoFLAGS(dstr) = IoFLAGS(sstr);
7792 SvANY(dstr) = new_XPVAV();
7793 SvCUR(dstr) = SvCUR(sstr);
7794 SvLEN(dstr) = SvLEN(sstr);
7795 SvIVX(dstr) = SvIVX(sstr);
7796 SvNVX(dstr) = SvNVX(sstr);
7797 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7798 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7799 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7800 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7801 if (AvARRAY((AV*)sstr)) {
7802 SV **dst_ary, **src_ary;
7803 SSize_t items = AvFILLp((AV*)sstr) + 1;
7805 src_ary = AvARRAY((AV*)sstr);
7806 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7807 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7808 SvPVX(dstr) = (char*)dst_ary;
7809 AvALLOC((AV*)dstr) = dst_ary;
7810 if (AvREAL((AV*)sstr)) {
7812 *dst_ary++ = sv_dup_inc(*src_ary++);
7816 *dst_ary++ = sv_dup(*src_ary++);
7818 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7819 while (items-- > 0) {
7820 *dst_ary++ = &PL_sv_undef;
7824 SvPVX(dstr) = Nullch;
7825 AvALLOC((AV*)dstr) = (SV**)NULL;
7829 SvANY(dstr) = new_XPVHV();
7830 SvCUR(dstr) = SvCUR(sstr);
7831 SvLEN(dstr) = SvLEN(sstr);
7832 SvIVX(dstr) = SvIVX(sstr);
7833 SvNVX(dstr) = SvNVX(sstr);
7834 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7835 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7836 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7837 if (HvARRAY((HV*)sstr)) {
7839 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7840 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7841 Newz(0, dxhv->xhv_array,
7842 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7843 while (i <= sxhv->xhv_max) {
7844 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7845 !!HvSHAREKEYS(sstr));
7848 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7851 SvPVX(dstr) = Nullch;
7852 HvEITER((HV*)dstr) = (HE*)NULL;
7854 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7855 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7858 SvANY(dstr) = new_XPVFM();
7859 FmLINES(dstr) = FmLINES(sstr);
7863 SvANY(dstr) = new_XPVCV();
7865 SvCUR(dstr) = SvCUR(sstr);
7866 SvLEN(dstr) = SvLEN(sstr);
7867 SvIVX(dstr) = SvIVX(sstr);
7868 SvNVX(dstr) = SvNVX(sstr);
7869 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7870 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7871 if (SvPVX(sstr) && SvLEN(sstr))
7872 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7874 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7875 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7876 CvSTART(dstr) = CvSTART(sstr);
7877 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7878 CvXSUB(dstr) = CvXSUB(sstr);
7879 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7880 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7881 CvDEPTH(dstr) = CvDEPTH(sstr);
7882 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7883 /* XXX padlists are real, but pretend to be not */
7884 AvREAL_on(CvPADLIST(sstr));
7885 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7886 AvREAL_off(CvPADLIST(sstr));
7887 AvREAL_off(CvPADLIST(dstr));
7890 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7891 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7892 CvFLAGS(dstr) = CvFLAGS(sstr);
7895 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7899 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7906 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7911 return (PERL_CONTEXT*)NULL;
7913 /* look for it in the table first */
7914 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7918 /* create anew and remember what it is */
7919 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7920 ptr_table_store(PL_ptr_table, cxs, ncxs);
7923 PERL_CONTEXT *cx = &cxs[ix];
7924 PERL_CONTEXT *ncx = &ncxs[ix];
7925 ncx->cx_type = cx->cx_type;
7926 if (CxTYPE(cx) == CXt_SUBST) {
7927 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7930 ncx->blk_oldsp = cx->blk_oldsp;
7931 ncx->blk_oldcop = cx->blk_oldcop;
7932 ncx->blk_oldretsp = cx->blk_oldretsp;
7933 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7934 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7935 ncx->blk_oldpm = cx->blk_oldpm;
7936 ncx->blk_gimme = cx->blk_gimme;
7937 switch (CxTYPE(cx)) {
7939 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7940 ? cv_dup_inc(cx->blk_sub.cv)
7941 : cv_dup(cx->blk_sub.cv));
7942 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7943 ? av_dup_inc(cx->blk_sub.argarray)
7945 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7946 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7947 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7948 ncx->blk_sub.lval = cx->blk_sub.lval;
7951 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7952 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7953 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7954 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7955 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7958 ncx->blk_loop.label = cx->blk_loop.label;
7959 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7960 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7961 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7962 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7963 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7964 ? cx->blk_loop.iterdata
7965 : gv_dup((GV*)cx->blk_loop.iterdata));
7966 ncx->blk_loop.oldcurpad
7967 = (SV**)ptr_table_fetch(PL_ptr_table,
7968 cx->blk_loop.oldcurpad);
7969 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7970 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7971 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7972 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7973 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7976 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7977 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7978 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7979 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7992 Perl_si_dup(pTHX_ PERL_SI *si)
7997 return (PERL_SI*)NULL;
7999 /* look for it in the table first */
8000 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8004 /* create anew and remember what it is */
8005 Newz(56, nsi, 1, PERL_SI);
8006 ptr_table_store(PL_ptr_table, si, nsi);
8008 nsi->si_stack = av_dup_inc(si->si_stack);
8009 nsi->si_cxix = si->si_cxix;
8010 nsi->si_cxmax = si->si_cxmax;
8011 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8012 nsi->si_type = si->si_type;
8013 nsi->si_prev = si_dup(si->si_prev);
8014 nsi->si_next = si_dup(si->si_next);
8015 nsi->si_markoff = si->si_markoff;
8020 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8021 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8022 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8023 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8024 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8025 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8026 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8027 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8028 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8029 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8030 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8031 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8034 #define pv_dup_inc(p) SAVEPV(p)
8035 #define pv_dup(p) SAVEPV(p)
8036 #define svp_dup_inc(p,pp) any_dup(p,pp)
8039 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8046 /* look for it in the table first */
8047 ret = ptr_table_fetch(PL_ptr_table, v);
8051 /* see if it is part of the interpreter structure */
8052 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8053 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8061 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8063 ANY *ss = proto_perl->Tsavestack;
8064 I32 ix = proto_perl->Tsavestack_ix;
8065 I32 max = proto_perl->Tsavestack_max;
8078 void (*dptr) (void*);
8079 void (*dxptr) (pTHXo_ void*);
8082 Newz(54, nss, max, ANY);
8088 case SAVEt_ITEM: /* normal string */
8089 sv = (SV*)POPPTR(ss,ix);
8090 TOPPTR(nss,ix) = sv_dup_inc(sv);
8091 sv = (SV*)POPPTR(ss,ix);
8092 TOPPTR(nss,ix) = sv_dup_inc(sv);
8094 case SAVEt_SV: /* scalar reference */
8095 sv = (SV*)POPPTR(ss,ix);
8096 TOPPTR(nss,ix) = sv_dup_inc(sv);
8097 gv = (GV*)POPPTR(ss,ix);
8098 TOPPTR(nss,ix) = gv_dup_inc(gv);
8100 case SAVEt_GENERIC_PVREF: /* generic char* */
8101 c = (char*)POPPTR(ss,ix);
8102 TOPPTR(nss,ix) = pv_dup(c);
8103 ptr = POPPTR(ss,ix);
8104 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8106 case SAVEt_GENERIC_SVREF: /* generic sv */
8107 case SAVEt_SVREF: /* scalar reference */
8108 sv = (SV*)POPPTR(ss,ix);
8109 TOPPTR(nss,ix) = sv_dup_inc(sv);
8110 ptr = POPPTR(ss,ix);
8111 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8113 case SAVEt_AV: /* array reference */
8114 av = (AV*)POPPTR(ss,ix);
8115 TOPPTR(nss,ix) = av_dup_inc(av);
8116 gv = (GV*)POPPTR(ss,ix);
8117 TOPPTR(nss,ix) = gv_dup(gv);
8119 case SAVEt_HV: /* hash reference */
8120 hv = (HV*)POPPTR(ss,ix);
8121 TOPPTR(nss,ix) = hv_dup_inc(hv);
8122 gv = (GV*)POPPTR(ss,ix);
8123 TOPPTR(nss,ix) = gv_dup(gv);
8125 case SAVEt_INT: /* int reference */
8126 ptr = POPPTR(ss,ix);
8127 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8128 intval = (int)POPINT(ss,ix);
8129 TOPINT(nss,ix) = intval;
8131 case SAVEt_LONG: /* long reference */
8132 ptr = POPPTR(ss,ix);
8133 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8134 longval = (long)POPLONG(ss,ix);
8135 TOPLONG(nss,ix) = longval;
8137 case SAVEt_I32: /* I32 reference */
8138 case SAVEt_I16: /* I16 reference */
8139 case SAVEt_I8: /* I8 reference */
8140 ptr = POPPTR(ss,ix);
8141 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8145 case SAVEt_IV: /* IV reference */
8146 ptr = POPPTR(ss,ix);
8147 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8151 case SAVEt_SPTR: /* SV* reference */
8152 ptr = POPPTR(ss,ix);
8153 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8154 sv = (SV*)POPPTR(ss,ix);
8155 TOPPTR(nss,ix) = sv_dup(sv);
8157 case SAVEt_VPTR: /* random* reference */
8158 ptr = POPPTR(ss,ix);
8159 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8160 ptr = POPPTR(ss,ix);
8161 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8163 case SAVEt_PPTR: /* char* reference */
8164 ptr = POPPTR(ss,ix);
8165 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8166 c = (char*)POPPTR(ss,ix);
8167 TOPPTR(nss,ix) = pv_dup(c);
8169 case SAVEt_HPTR: /* HV* reference */
8170 ptr = POPPTR(ss,ix);
8171 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8172 hv = (HV*)POPPTR(ss,ix);
8173 TOPPTR(nss,ix) = hv_dup(hv);
8175 case SAVEt_APTR: /* AV* reference */
8176 ptr = POPPTR(ss,ix);
8177 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8178 av = (AV*)POPPTR(ss,ix);
8179 TOPPTR(nss,ix) = av_dup(av);
8182 gv = (GV*)POPPTR(ss,ix);
8183 TOPPTR(nss,ix) = gv_dup(gv);
8185 case SAVEt_GP: /* scalar reference */
8186 gp = (GP*)POPPTR(ss,ix);
8187 TOPPTR(nss,ix) = gp = gp_dup(gp);
8188 (void)GpREFCNT_inc(gp);
8189 gv = (GV*)POPPTR(ss,ix);
8190 TOPPTR(nss,ix) = gv_dup_inc(c);
8191 c = (char*)POPPTR(ss,ix);
8192 TOPPTR(nss,ix) = pv_dup(c);
8199 sv = (SV*)POPPTR(ss,ix);
8200 TOPPTR(nss,ix) = sv_dup_inc(sv);
8203 ptr = POPPTR(ss,ix);
8204 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8205 /* these are assumed to be refcounted properly */
8206 switch (((OP*)ptr)->op_type) {
8213 TOPPTR(nss,ix) = ptr;
8218 TOPPTR(nss,ix) = Nullop;
8223 TOPPTR(nss,ix) = Nullop;
8226 c = (char*)POPPTR(ss,ix);
8227 TOPPTR(nss,ix) = pv_dup_inc(c);
8230 longval = POPLONG(ss,ix);
8231 TOPLONG(nss,ix) = longval;
8234 hv = (HV*)POPPTR(ss,ix);
8235 TOPPTR(nss,ix) = hv_dup_inc(hv);
8236 c = (char*)POPPTR(ss,ix);
8237 TOPPTR(nss,ix) = pv_dup_inc(c);
8241 case SAVEt_DESTRUCTOR:
8242 ptr = POPPTR(ss,ix);
8243 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8244 dptr = POPDPTR(ss,ix);
8245 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8247 case SAVEt_DESTRUCTOR_X:
8248 ptr = POPPTR(ss,ix);
8249 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8250 dxptr = POPDXPTR(ss,ix);
8251 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8253 case SAVEt_REGCONTEXT:
8259 case SAVEt_STACK_POS: /* Position on Perl stack */
8263 case SAVEt_AELEM: /* array element */
8264 sv = (SV*)POPPTR(ss,ix);
8265 TOPPTR(nss,ix) = sv_dup_inc(sv);
8268 av = (AV*)POPPTR(ss,ix);
8269 TOPPTR(nss,ix) = av_dup_inc(av);
8271 case SAVEt_HELEM: /* hash element */
8272 sv = (SV*)POPPTR(ss,ix);
8273 TOPPTR(nss,ix) = sv_dup_inc(sv);
8274 sv = (SV*)POPPTR(ss,ix);
8275 TOPPTR(nss,ix) = sv_dup_inc(sv);
8276 hv = (HV*)POPPTR(ss,ix);
8277 TOPPTR(nss,ix) = hv_dup_inc(hv);
8280 ptr = POPPTR(ss,ix);
8281 TOPPTR(nss,ix) = ptr;
8288 av = (AV*)POPPTR(ss,ix);
8289 TOPPTR(nss,ix) = av_dup(av);
8292 longval = (long)POPLONG(ss,ix);
8293 TOPLONG(nss,ix) = longval;
8294 ptr = POPPTR(ss,ix);
8295 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8296 sv = (SV*)POPPTR(ss,ix);
8297 TOPPTR(nss,ix) = sv_dup(sv);
8300 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8312 perl_clone(PerlInterpreter *proto_perl, UV flags)
8315 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8318 #ifdef PERL_IMPLICIT_SYS
8319 return perl_clone_using(proto_perl, flags,
8321 proto_perl->IMemShared,
8322 proto_perl->IMemParse,
8332 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8333 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8334 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8335 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8336 struct IPerlDir* ipD, struct IPerlSock* ipS,
8337 struct IPerlProc* ipP)
8339 /* XXX many of the string copies here can be optimized if they're
8340 * constants; they need to be allocated as common memory and just
8341 * their pointers copied. */
8345 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8347 PERL_SET_THX(pPerl);
8348 # else /* !PERL_OBJECT */
8349 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8350 PERL_SET_THX(my_perl);
8353 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8358 # else /* !DEBUGGING */
8359 Zero(my_perl, 1, PerlInterpreter);
8360 # endif /* DEBUGGING */
8364 PL_MemShared = ipMS;
8372 # endif /* PERL_OBJECT */
8373 #else /* !PERL_IMPLICIT_SYS */
8375 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8376 PERL_SET_THX(my_perl);
8379 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8384 # else /* !DEBUGGING */
8385 Zero(my_perl, 1, PerlInterpreter);
8386 # endif /* DEBUGGING */
8387 #endif /* PERL_IMPLICIT_SYS */
8390 PL_xiv_arenaroot = NULL;
8392 PL_xnv_arenaroot = NULL;
8394 PL_xrv_arenaroot = NULL;
8396 PL_xpv_arenaroot = NULL;
8398 PL_xpviv_arenaroot = NULL;
8399 PL_xpviv_root = NULL;
8400 PL_xpvnv_arenaroot = NULL;
8401 PL_xpvnv_root = NULL;
8402 PL_xpvcv_arenaroot = NULL;
8403 PL_xpvcv_root = NULL;
8404 PL_xpvav_arenaroot = NULL;
8405 PL_xpvav_root = NULL;
8406 PL_xpvhv_arenaroot = NULL;
8407 PL_xpvhv_root = NULL;
8408 PL_xpvmg_arenaroot = NULL;
8409 PL_xpvmg_root = NULL;
8410 PL_xpvlv_arenaroot = NULL;
8411 PL_xpvlv_root = NULL;
8412 PL_xpvbm_arenaroot = NULL;
8413 PL_xpvbm_root = NULL;
8414 PL_he_arenaroot = NULL;
8416 PL_nice_chunk = NULL;
8417 PL_nice_chunk_size = 0;
8420 PL_sv_root = Nullsv;
8421 PL_sv_arenaroot = Nullsv;
8423 PL_debug = proto_perl->Idebug;
8425 /* create SV map for pointer relocation */
8426 PL_ptr_table = ptr_table_new();
8428 /* initialize these special pointers as early as possible */
8429 SvANY(&PL_sv_undef) = NULL;
8430 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8431 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8432 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8435 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8437 SvANY(&PL_sv_no) = new_XPVNV();
8439 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8440 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8441 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8442 SvCUR(&PL_sv_no) = 0;
8443 SvLEN(&PL_sv_no) = 1;
8444 SvNVX(&PL_sv_no) = 0;
8445 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8448 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8450 SvANY(&PL_sv_yes) = new_XPVNV();
8452 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8453 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8454 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8455 SvCUR(&PL_sv_yes) = 1;
8456 SvLEN(&PL_sv_yes) = 2;
8457 SvNVX(&PL_sv_yes) = 1;
8458 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8460 /* create shared string table */
8461 PL_strtab = newHV();
8462 HvSHAREKEYS_off(PL_strtab);
8463 hv_ksplit(PL_strtab, 512);
8464 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8466 PL_compiling = proto_perl->Icompiling;
8467 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8468 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8469 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8470 if (!specialWARN(PL_compiling.cop_warnings))
8471 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8472 if (!specialCopIO(PL_compiling.cop_io))
8473 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8474 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8476 /* pseudo environmental stuff */
8477 PL_origargc = proto_perl->Iorigargc;
8479 New(0, PL_origargv, i+1, char*);
8480 PL_origargv[i] = '\0';
8482 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8484 PL_envgv = gv_dup(proto_perl->Ienvgv);
8485 PL_incgv = gv_dup(proto_perl->Iincgv);
8486 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8487 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8488 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8489 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8492 PL_minus_c = proto_perl->Iminus_c;
8493 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8494 PL_localpatches = proto_perl->Ilocalpatches;
8495 PL_splitstr = proto_perl->Isplitstr;
8496 PL_preprocess = proto_perl->Ipreprocess;
8497 PL_minus_n = proto_perl->Iminus_n;
8498 PL_minus_p = proto_perl->Iminus_p;
8499 PL_minus_l = proto_perl->Iminus_l;
8500 PL_minus_a = proto_perl->Iminus_a;
8501 PL_minus_F = proto_perl->Iminus_F;
8502 PL_doswitches = proto_perl->Idoswitches;
8503 PL_dowarn = proto_perl->Idowarn;
8504 PL_doextract = proto_perl->Idoextract;
8505 PL_sawampersand = proto_perl->Isawampersand;
8506 PL_unsafe = proto_perl->Iunsafe;
8507 PL_inplace = SAVEPV(proto_perl->Iinplace);
8508 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8509 PL_perldb = proto_perl->Iperldb;
8510 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8512 /* magical thingies */
8513 /* XXX time(&PL_basetime) when asked for? */
8514 PL_basetime = proto_perl->Ibasetime;
8515 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8517 PL_maxsysfd = proto_perl->Imaxsysfd;
8518 PL_multiline = proto_perl->Imultiline;
8519 PL_statusvalue = proto_perl->Istatusvalue;
8521 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8524 /* shortcuts to various I/O objects */
8525 PL_stdingv = gv_dup(proto_perl->Istdingv);
8526 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8527 PL_defgv = gv_dup(proto_perl->Idefgv);
8528 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8529 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8530 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8532 /* shortcuts to regexp stuff */
8533 PL_replgv = gv_dup(proto_perl->Ireplgv);
8535 /* shortcuts to misc objects */
8536 PL_errgv = gv_dup(proto_perl->Ierrgv);
8538 /* shortcuts to debugging objects */
8539 PL_DBgv = gv_dup(proto_perl->IDBgv);
8540 PL_DBline = gv_dup(proto_perl->IDBline);
8541 PL_DBsub = gv_dup(proto_perl->IDBsub);
8542 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8543 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8544 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8545 PL_lineary = av_dup(proto_perl->Ilineary);
8546 PL_dbargs = av_dup(proto_perl->Idbargs);
8549 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8550 PL_curstash = hv_dup(proto_perl->Tcurstash);
8551 PL_debstash = hv_dup(proto_perl->Idebstash);
8552 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8553 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8555 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8556 PL_endav = av_dup_inc(proto_perl->Iendav);
8557 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8558 PL_initav = av_dup_inc(proto_perl->Iinitav);
8560 PL_sub_generation = proto_perl->Isub_generation;
8562 /* funky return mechanisms */
8563 PL_forkprocess = proto_perl->Iforkprocess;
8565 /* subprocess state */
8566 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8568 /* internal state */
8569 PL_tainting = proto_perl->Itainting;
8570 PL_maxo = proto_perl->Imaxo;
8571 if (proto_perl->Iop_mask)
8572 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8574 PL_op_mask = Nullch;
8576 /* current interpreter roots */
8577 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8578 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8579 PL_main_start = proto_perl->Imain_start;
8580 PL_eval_root = proto_perl->Ieval_root;
8581 PL_eval_start = proto_perl->Ieval_start;
8583 /* runtime control stuff */
8584 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8585 PL_copline = proto_perl->Icopline;
8587 PL_filemode = proto_perl->Ifilemode;
8588 PL_lastfd = proto_perl->Ilastfd;
8589 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8592 PL_gensym = proto_perl->Igensym;
8593 PL_preambled = proto_perl->Ipreambled;
8594 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8595 PL_laststatval = proto_perl->Ilaststatval;
8596 PL_laststype = proto_perl->Ilaststype;
8597 PL_mess_sv = Nullsv;
8599 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8600 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8602 /* interpreter atexit processing */
8603 PL_exitlistlen = proto_perl->Iexitlistlen;
8604 if (PL_exitlistlen) {
8605 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8606 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8609 PL_exitlist = (PerlExitListEntry*)NULL;
8610 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8612 PL_profiledata = NULL;
8613 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8614 /* PL_rsfp_filters entries have fake IoDIRP() */
8615 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8617 PL_compcv = cv_dup(proto_perl->Icompcv);
8618 PL_comppad = av_dup(proto_perl->Icomppad);
8619 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8620 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8621 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8622 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8623 proto_perl->Tcurpad);
8625 #ifdef HAVE_INTERP_INTERN
8626 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8629 /* more statics moved here */
8630 PL_generation = proto_perl->Igeneration;
8631 PL_DBcv = cv_dup(proto_perl->IDBcv);
8633 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8634 PL_in_clean_all = proto_perl->Iin_clean_all;
8636 PL_uid = proto_perl->Iuid;
8637 PL_euid = proto_perl->Ieuid;
8638 PL_gid = proto_perl->Igid;
8639 PL_egid = proto_perl->Iegid;
8640 PL_nomemok = proto_perl->Inomemok;
8641 PL_an = proto_perl->Ian;
8642 PL_cop_seqmax = proto_perl->Icop_seqmax;
8643 PL_op_seqmax = proto_perl->Iop_seqmax;
8644 PL_evalseq = proto_perl->Ievalseq;
8645 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8646 PL_origalen = proto_perl->Iorigalen;
8647 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8648 PL_osname = SAVEPV(proto_perl->Iosname);
8649 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8650 PL_sighandlerp = proto_perl->Isighandlerp;
8653 PL_runops = proto_perl->Irunops;
8655 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8658 PL_cshlen = proto_perl->Icshlen;
8659 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8662 PL_lex_state = proto_perl->Ilex_state;
8663 PL_lex_defer = proto_perl->Ilex_defer;
8664 PL_lex_expect = proto_perl->Ilex_expect;
8665 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8666 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8667 PL_lex_starts = proto_perl->Ilex_starts;
8668 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8669 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8670 PL_lex_op = proto_perl->Ilex_op;
8671 PL_lex_inpat = proto_perl->Ilex_inpat;
8672 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8673 PL_lex_brackets = proto_perl->Ilex_brackets;
8674 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8675 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8676 PL_lex_casemods = proto_perl->Ilex_casemods;
8677 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8678 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8680 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8681 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8682 PL_nexttoke = proto_perl->Inexttoke;
8684 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8685 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8686 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8687 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8688 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8689 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8690 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8691 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8692 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8693 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8694 PL_pending_ident = proto_perl->Ipending_ident;
8695 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8697 PL_expect = proto_perl->Iexpect;
8699 PL_multi_start = proto_perl->Imulti_start;
8700 PL_multi_end = proto_perl->Imulti_end;
8701 PL_multi_open = proto_perl->Imulti_open;
8702 PL_multi_close = proto_perl->Imulti_close;
8704 PL_error_count = proto_perl->Ierror_count;
8705 PL_subline = proto_perl->Isubline;
8706 PL_subname = sv_dup_inc(proto_perl->Isubname);
8708 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8709 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8710 PL_padix = proto_perl->Ipadix;
8711 PL_padix_floor = proto_perl->Ipadix_floor;
8712 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8714 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8715 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8716 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8717 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8718 PL_last_lop_op = proto_perl->Ilast_lop_op;
8719 PL_in_my = proto_perl->Iin_my;
8720 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8722 PL_cryptseen = proto_perl->Icryptseen;
8725 PL_hints = proto_perl->Ihints;
8727 PL_amagic_generation = proto_perl->Iamagic_generation;
8729 #ifdef USE_LOCALE_COLLATE
8730 PL_collation_ix = proto_perl->Icollation_ix;
8731 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8732 PL_collation_standard = proto_perl->Icollation_standard;
8733 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8734 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8735 #endif /* USE_LOCALE_COLLATE */
8737 #ifdef USE_LOCALE_NUMERIC
8738 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8739 PL_numeric_standard = proto_perl->Inumeric_standard;
8740 PL_numeric_local = proto_perl->Inumeric_local;
8741 PL_numeric_radix = proto_perl->Inumeric_radix;
8742 #endif /* !USE_LOCALE_NUMERIC */
8744 /* utf8 character classes */
8745 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8746 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8747 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8748 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8749 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8750 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8751 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8752 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8753 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8754 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8755 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8756 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8757 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8758 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8759 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8760 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8761 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8764 PL_last_swash_hv = Nullhv; /* reinits on demand */
8765 PL_last_swash_klen = 0;
8766 PL_last_swash_key[0]= '\0';
8767 PL_last_swash_tmps = (U8*)NULL;
8768 PL_last_swash_slen = 0;
8770 /* perly.c globals */
8771 PL_yydebug = proto_perl->Iyydebug;
8772 PL_yynerrs = proto_perl->Iyynerrs;
8773 PL_yyerrflag = proto_perl->Iyyerrflag;
8774 PL_yychar = proto_perl->Iyychar;
8775 PL_yyval = proto_perl->Iyyval;
8776 PL_yylval = proto_perl->Iyylval;
8778 PL_glob_index = proto_perl->Iglob_index;
8779 PL_srand_called = proto_perl->Isrand_called;
8780 PL_uudmap['M'] = 0; /* reinits on demand */
8781 PL_bitcount = Nullch; /* reinits on demand */
8783 if (proto_perl->Ipsig_ptr) {
8784 int sig_num[] = { SIG_NUM };
8785 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8786 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8787 for (i = 1; PL_sig_name[i]; i++) {
8788 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8789 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8793 PL_psig_ptr = (SV**)NULL;
8794 PL_psig_name = (SV**)NULL;
8797 /* thrdvar.h stuff */
8800 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8801 PL_tmps_ix = proto_perl->Ttmps_ix;
8802 PL_tmps_max = proto_perl->Ttmps_max;
8803 PL_tmps_floor = proto_perl->Ttmps_floor;
8804 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8806 while (i <= PL_tmps_ix) {
8807 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8811 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8812 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8813 Newz(54, PL_markstack, i, I32);
8814 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8815 - proto_perl->Tmarkstack);
8816 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8817 - proto_perl->Tmarkstack);
8818 Copy(proto_perl->Tmarkstack, PL_markstack,
8819 PL_markstack_ptr - PL_markstack + 1, I32);
8821 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8822 * NOTE: unlike the others! */
8823 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8824 PL_scopestack_max = proto_perl->Tscopestack_max;
8825 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8826 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8828 /* next push_return() sets PL_retstack[PL_retstack_ix]
8829 * NOTE: unlike the others! */
8830 PL_retstack_ix = proto_perl->Tretstack_ix;
8831 PL_retstack_max = proto_perl->Tretstack_max;
8832 Newz(54, PL_retstack, PL_retstack_max, OP*);
8833 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8835 /* NOTE: si_dup() looks at PL_markstack */
8836 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8838 /* PL_curstack = PL_curstackinfo->si_stack; */
8839 PL_curstack = av_dup(proto_perl->Tcurstack);
8840 PL_mainstack = av_dup(proto_perl->Tmainstack);
8842 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8843 PL_stack_base = AvARRAY(PL_curstack);
8844 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8845 - proto_perl->Tstack_base);
8846 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8848 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8849 * NOTE: unlike the others! */
8850 PL_savestack_ix = proto_perl->Tsavestack_ix;
8851 PL_savestack_max = proto_perl->Tsavestack_max;
8852 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8853 PL_savestack = ss_dup(proto_perl);
8857 ENTER; /* perl_destruct() wants to LEAVE; */
8860 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8861 PL_top_env = &PL_start_env;
8863 PL_op = proto_perl->Top;
8866 PL_Xpv = (XPV*)NULL;
8867 PL_na = proto_perl->Tna;
8869 PL_statbuf = proto_perl->Tstatbuf;
8870 PL_statcache = proto_perl->Tstatcache;
8871 PL_statgv = gv_dup(proto_perl->Tstatgv);
8872 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8874 PL_timesbuf = proto_perl->Ttimesbuf;
8877 PL_tainted = proto_perl->Ttainted;
8878 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8879 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8880 PL_rs = sv_dup_inc(proto_perl->Trs);
8881 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8882 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
8883 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8884 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8885 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8886 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8887 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8889 PL_restartop = proto_perl->Trestartop;
8890 PL_in_eval = proto_perl->Tin_eval;
8891 PL_delaymagic = proto_perl->Tdelaymagic;
8892 PL_dirty = proto_perl->Tdirty;
8893 PL_localizing = proto_perl->Tlocalizing;
8895 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8896 PL_protect = proto_perl->Tprotect;
8898 PL_errors = sv_dup_inc(proto_perl->Terrors);
8899 PL_av_fetch_sv = Nullsv;
8900 PL_hv_fetch_sv = Nullsv;
8901 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8902 PL_modcount = proto_perl->Tmodcount;
8903 PL_lastgotoprobe = Nullop;
8904 PL_dumpindent = proto_perl->Tdumpindent;
8906 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8907 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8908 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8909 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8910 PL_sortcxix = proto_perl->Tsortcxix;
8911 PL_efloatbuf = Nullch; /* reinits on demand */
8912 PL_efloatsize = 0; /* reinits on demand */
8916 PL_screamfirst = NULL;
8917 PL_screamnext = NULL;
8918 PL_maxscream = -1; /* reinits on demand */
8919 PL_lastscream = Nullsv;
8921 PL_watchaddr = NULL;
8922 PL_watchok = Nullch;
8924 PL_regdummy = proto_perl->Tregdummy;
8925 PL_regcomp_parse = Nullch;
8926 PL_regxend = Nullch;
8927 PL_regcode = (regnode*)NULL;
8930 PL_regprecomp = Nullch;
8935 PL_seen_zerolen = 0;
8937 PL_regcomp_rx = (regexp*)NULL;
8939 PL_colorset = 0; /* reinits PL_colors[] */
8940 /*PL_colors[6] = {0,0,0,0,0,0};*/
8941 PL_reg_whilem_seen = 0;
8942 PL_reginput = Nullch;
8945 PL_regstartp = (I32*)NULL;
8946 PL_regendp = (I32*)NULL;
8947 PL_reglastparen = (U32*)NULL;
8948 PL_regtill = Nullch;
8950 PL_reg_start_tmp = (char**)NULL;
8951 PL_reg_start_tmpl = 0;
8952 PL_regdata = (struct reg_data*)NULL;
8955 PL_reg_eval_set = 0;
8957 PL_regprogram = (regnode*)NULL;
8959 PL_regcc = (CURCUR*)NULL;
8960 PL_reg_call_cc = (struct re_cc_state*)NULL;
8961 PL_reg_re = (regexp*)NULL;
8962 PL_reg_ganch = Nullch;
8964 PL_reg_magic = (MAGIC*)NULL;
8966 PL_reg_oldcurpm = (PMOP*)NULL;
8967 PL_reg_curpm = (PMOP*)NULL;
8968 PL_reg_oldsaved = Nullch;
8969 PL_reg_oldsavedlen = 0;
8971 PL_reg_leftiter = 0;
8972 PL_reg_poscache = Nullch;
8973 PL_reg_poscache_size= 0;
8975 /* RE engine - function pointers */
8976 PL_regcompp = proto_perl->Tregcompp;
8977 PL_regexecp = proto_perl->Tregexecp;
8978 PL_regint_start = proto_perl->Tregint_start;
8979 PL_regint_string = proto_perl->Tregint_string;
8980 PL_regfree = proto_perl->Tregfree;
8982 PL_reginterp_cnt = 0;
8983 PL_reg_starttry = 0;
8986 return (PerlInterpreter*)pPerl;
8992 #else /* !USE_ITHREADS */
8998 #endif /* USE_ITHREADS */
9001 do_report_used(pTHXo_ SV *sv)
9003 if (SvTYPE(sv) != SVTYPEMASK) {
9004 PerlIO_printf(Perl_debug_log, "****\n");
9010 do_clean_objs(pTHXo_ SV *sv)
9014 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9015 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9016 if (SvWEAKREF(sv)) {
9027 /* XXX Might want to check arrays, etc. */
9030 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9032 do_clean_named_objs(pTHXo_ SV *sv)
9034 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9035 if ( SvOBJECT(GvSV(sv)) ||
9036 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9037 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9038 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9039 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9041 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9049 do_clean_all(pTHXo_ SV *sv)
9051 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9052 SvFLAGS(sv) |= SVf_BREAK;