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 char *num_begin = SvPVX(sv);
2071 int save_errno = errno;
2073 /* seems that strtoul taking numbers that start with - is
2074 implementation dependant, and can't be relied upon. */
2075 if (numtype & IS_NUMBER_NEG) {
2076 /* Not totally defensive. assumine that looks_like_num
2077 didn't lie about a - sign */
2078 while (isSPACE(*num_begin))
2080 if (*num_begin == '-')
2084 /* Is it an integer that we could convert with strtoul?
2085 So try it, and if it doesn't set errno then it's pukka.
2086 This should be faster than going atof and then thinking. */
2087 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2088 == IS_NUMBER_TO_INT_BY_STRTOL)
2089 && ((errno = 0), 1) /* always true */
2090 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2092 /* If known to be negative, check it didn't undeflow IV
2093 XXX possibly we should put more negative values as NVs
2094 direct rather than go via atof below */
2095 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2098 if (SvTYPE(sv) < SVt_PVIV)
2099 sv_upgrade(sv, SVt_PVIV);
2102 /* If it's negative must use IV.
2103 IV-over-UV optimisation */
2104 if (numtype & IS_NUMBER_NEG) {
2106 } else if (u <= (UV) IV_MAX) {
2109 /* it didn't overflow, and it was positive. */
2118 /* Hopefully trace flow will optimise this away where possible
2122 /* It wasn't an integer, or it overflowed, or we don't have
2123 strtol. Do things the slow way - check if it's a IV etc. */
2124 d = Atof(SvPVX(sv));
2126 if (SvTYPE(sv) < SVt_PVNV)
2127 sv_upgrade(sv, SVt_PVNV);
2130 if (! numtype && ckWARN(WARN_NUMERIC))
2133 #if defined(USE_LONG_DOUBLE)
2134 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2135 PTR2UV(sv), SvNVX(sv)));
2137 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2138 PTR2UV(sv), SvNVX(sv)));
2141 #ifdef NV_PRESERVES_UV
2142 (void)SvIOKp_on(sv);
2144 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2145 SvIVX(sv) = I_V(SvNVX(sv));
2146 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2149 /* Integer is imprecise. NOK, IOKp */
2151 /* UV will not work better than IV */
2153 if (SvNVX(sv) > (NV)UV_MAX) {
2155 /* Integer is inaccurate. NOK, IOKp, is UV */
2159 SvUVX(sv) = U_V(SvNVX(sv));
2160 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2161 NV preservse UV so can do correct comparison. */
2162 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2166 /* Integer is imprecise. NOK, IOKp, is UV */
2171 #else /* NV_PRESERVES_UV */
2172 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2173 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2174 /* Small enough to preserve all bits. */
2175 (void)SvIOKp_on(sv);
2177 SvIVX(sv) = I_V(SvNVX(sv));
2178 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2180 /* Assumption: first non-preserved integer is < IV_MAX,
2181 this NV is in the preserved range, therefore: */
2182 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2184 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);
2187 sv_2iuv_non_preserve (sv, numtype);
2188 #endif /* NV_PRESERVES_UV */
2193 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2194 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2197 if (SvTYPE(sv) < SVt_IV)
2198 /* Typically the caller expects that sv_any is not NULL now. */
2199 sv_upgrade(sv, SVt_IV);
2203 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2204 PTR2UV(sv),SvUVX(sv)));
2205 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2209 Perl_sv_2nv(pTHX_ register SV *sv)
2213 if (SvGMAGICAL(sv)) {
2217 if (SvPOKp(sv) && SvLEN(sv)) {
2218 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2220 return Atof(SvPVX(sv));
2224 return (NV)SvUVX(sv);
2226 return (NV)SvIVX(sv);
2229 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2230 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2236 if (SvTHINKFIRST(sv)) {
2239 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2240 (SvRV(tmpstr) != SvRV(sv)))
2241 return SvNV(tmpstr);
2242 return PTR2NV(SvRV(sv));
2244 if (SvREADONLY(sv) && SvFAKE(sv)) {
2245 sv_force_normal(sv);
2247 if (SvREADONLY(sv) && !SvOK(sv)) {
2248 if (ckWARN(WARN_UNINITIALIZED))
2253 if (SvTYPE(sv) < SVt_NV) {
2254 if (SvTYPE(sv) == SVt_IV)
2255 sv_upgrade(sv, SVt_PVNV);
2257 sv_upgrade(sv, SVt_NV);
2258 #if defined(USE_LONG_DOUBLE)
2260 STORE_NUMERIC_LOCAL_SET_STANDARD();
2261 PerlIO_printf(Perl_debug_log,
2262 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2263 PTR2UV(sv), SvNVX(sv));
2264 RESTORE_NUMERIC_LOCAL();
2268 STORE_NUMERIC_LOCAL_SET_STANDARD();
2269 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2270 PTR2UV(sv), SvNVX(sv));
2271 RESTORE_NUMERIC_LOCAL();
2275 else if (SvTYPE(sv) < SVt_PVNV)
2276 sv_upgrade(sv, SVt_PVNV);
2278 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2280 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2281 #ifdef NV_PRESERVES_UV
2284 /* Only set the public NV OK flag if this NV preserves the IV */
2285 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2286 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2287 : (SvIVX(sv) == I_V(SvNVX(sv))))
2293 else if (SvPOKp(sv) && SvLEN(sv)) {
2294 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2296 SvNVX(sv) = Atof(SvPVX(sv));
2297 #ifdef NV_PRESERVES_UV
2300 /* Only set the public NV OK flag if this NV preserves the value in
2301 the PV at least as well as an IV/UV would.
2302 Not sure how to do this 100% reliably. */
2303 /* if that shift count is out of range then Configure's test is
2304 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2306 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2307 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2308 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2309 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2310 /* Definitely too large/small to fit in an integer, so no loss
2311 of precision going to integer in the future via NV */
2314 /* Is it something we can run through strtol etc (ie no
2315 trailing exponent part)? */
2316 int numtype = looks_like_number(sv);
2317 /* XXX probably should cache this if called above */
2320 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2321 /* Can't use strtol etc to convert this string, so don't try */
2324 sv_2inuv_non_preserve (sv, numtype);
2326 #endif /* NV_PRESERVES_UV */
2329 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2331 if (SvTYPE(sv) < SVt_NV)
2332 /* Typically the caller expects that sv_any is not NULL now. */
2333 /* XXX Ilya implies that this is a bug in callers that assume this
2334 and ideally should be fixed. */
2335 sv_upgrade(sv, SVt_NV);
2338 #if defined(USE_LONG_DOUBLE)
2340 STORE_NUMERIC_LOCAL_SET_STANDARD();
2341 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2342 PTR2UV(sv), SvNVX(sv));
2343 RESTORE_NUMERIC_LOCAL();
2347 STORE_NUMERIC_LOCAL_SET_STANDARD();
2348 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2349 PTR2UV(sv), SvNVX(sv));
2350 RESTORE_NUMERIC_LOCAL();
2357 S_asIV(pTHX_ SV *sv)
2359 I32 numtype = looks_like_number(sv);
2362 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2363 return Atol(SvPVX(sv));
2365 if (ckWARN(WARN_NUMERIC))
2368 d = Atof(SvPVX(sv));
2373 S_asUV(pTHX_ SV *sv)
2375 I32 numtype = looks_like_number(sv);
2378 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2379 return Strtoul(SvPVX(sv), Null(char**), 10);
2382 if (ckWARN(WARN_NUMERIC))
2385 return U_V(Atof(SvPVX(sv)));
2389 * Returns a combination of (advisory only - can get false negatives)
2390 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2391 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2392 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2393 * 0 if does not look like number.
2395 * (atol and strtol stop when they hit a decimal point. strtol will return
2396 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2397 * do this, and vendors have had 11 years to get it right.
2398 * However, will try to make it still work with only atol
2400 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2401 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2402 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2403 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2404 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2405 * IS_NUMBER_NOT_INT saw "." or "e"
2407 * IS_NUMBER_INFINITY
2411 =for apidoc looks_like_number
2413 Test if an the content of an SV looks like a number (or is a
2414 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2415 issue a non-numeric warning), even if your atof() doesn't grok them.
2421 Perl_looks_like_number(pTHX_ SV *sv)
2424 register char *send;
2425 register char *sbegin;
2426 register char *nbegin;
2435 else if (SvPOKp(sv))
2436 sbegin = SvPV(sv, len);
2439 send = sbegin + len;
2446 numtype = IS_NUMBER_NEG;
2453 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2454 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2455 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2456 * will need (int)atof().
2459 /* next must be digit or the radix separator or beginning of infinity */
2463 } while (isDIGIT(*s));
2465 /* Aaargh. long long really is irritating.
2466 In the gospel according to ANSI 1989, it is an axiom that "long"
2467 is the longest integer type, and that if you don't know how long
2468 something is you can cast it to long, and nothing will be lost
2469 (except possibly speed of execution if long is slower than the
2471 Now, one can't be sure if the old rules apply, or long long
2472 (or some other newfangled thing) is actually longer than the
2473 (formerly) longest thing.
2475 /* This lot will work for 64 bit *as long as* either
2476 either long is 64 bit
2477 or we can find both strtol/strtoq and strtoul/strtouq
2478 If not, we really should refuse to let the user use 64 bit IVs
2479 By "64 bit" I really mean IVs that don't get preserved by NVs
2480 It also should work for 128 bit IVs. Can any lend me a machine to
2483 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2484 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2485 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2486 ? sizeof(long) : sizeof (IV))*8-1))
2487 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2489 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2490 digit less (IV_MAX= 9223372036854775807,
2491 UV_MAX= 18446744073709551615) so be cautious */
2492 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2495 #ifdef USE_LOCALE_NUMERIC
2496 || IS_NUMERIC_RADIX(*s)
2500 numtype |= IS_NUMBER_NOT_INT;
2501 while (isDIGIT(*s)) /* optional digits after the radix */
2506 #ifdef USE_LOCALE_NUMERIC
2507 || IS_NUMERIC_RADIX(*s)
2511 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2512 /* no digits before the radix means we need digits after it */
2516 } while (isDIGIT(*s));
2521 else if (*s == 'I' || *s == 'i') {
2522 s++; if (*s != 'N' && *s != 'n') return 0;
2523 s++; if (*s != 'F' && *s != 'f') return 0;
2524 s++; if (*s == 'I' || *s == 'i') {
2525 s++; if (*s != 'N' && *s != 'n') return 0;
2526 s++; if (*s != 'I' && *s != 'i') return 0;
2527 s++; if (*s != 'T' && *s != 't') return 0;
2528 s++; if (*s != 'Y' && *s != 'y') return 0;
2537 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2538 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2540 /* we can have an optional exponent part */
2541 if (*s == 'e' || *s == 'E') {
2542 numtype &= IS_NUMBER_NEG;
2543 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2545 if (*s == '+' || *s == '-')
2550 } while (isDIGIT(*s));
2560 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2561 return IS_NUMBER_TO_INT_BY_ATOL;
2566 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2569 return sv_2pv(sv, &n_a);
2572 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2574 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2576 char *ptr = buf + TYPE_CHARS(UV);
2590 *--ptr = '0' + (uv % 10);
2599 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2604 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2605 char *tmpbuf = tbuf;
2611 if (SvGMAGICAL(sv)) {
2619 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2621 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2626 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2631 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2632 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2639 if (SvTHINKFIRST(sv)) {
2642 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2643 (SvRV(tmpstr) != SvRV(sv)))
2644 return SvPV(tmpstr,*lp);
2651 switch (SvTYPE(sv)) {
2653 if ( ((SvFLAGS(sv) &
2654 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2655 == (SVs_OBJECT|SVs_RMG))
2656 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2657 && (mg = mg_find(sv, 'r'))) {
2658 regexp *re = (regexp *)mg->mg_obj;
2661 char *fptr = "msix";
2666 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2668 while((ch = *fptr++)) {
2670 reflags[left++] = ch;
2673 reflags[right--] = ch;
2678 reflags[left] = '-';
2682 mg->mg_len = re->prelen + 4 + left;
2683 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2684 Copy("(?", mg->mg_ptr, 2, char);
2685 Copy(reflags, mg->mg_ptr+2, left, char);
2686 Copy(":", mg->mg_ptr+left+2, 1, char);
2687 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2688 mg->mg_ptr[mg->mg_len - 1] = ')';
2689 mg->mg_ptr[mg->mg_len] = 0;
2691 PL_reginterp_cnt += re->program[0].next_off;
2703 case SVt_PVBM: if (SvROK(sv))
2706 s = "SCALAR"; break;
2707 case SVt_PVLV: s = "LVALUE"; break;
2708 case SVt_PVAV: s = "ARRAY"; break;
2709 case SVt_PVHV: s = "HASH"; break;
2710 case SVt_PVCV: s = "CODE"; break;
2711 case SVt_PVGV: s = "GLOB"; break;
2712 case SVt_PVFM: s = "FORMAT"; break;
2713 case SVt_PVIO: s = "IO"; break;
2714 default: s = "UNKNOWN"; break;
2718 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2721 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2727 if (SvREADONLY(sv) && !SvOK(sv)) {
2728 if (ckWARN(WARN_UNINITIALIZED))
2734 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2735 /* I'm assuming that if both IV and NV are equally valid then
2736 converting the IV is going to be more efficient */
2737 U32 isIOK = SvIOK(sv);
2738 U32 isUIOK = SvIsUV(sv);
2739 char buf[TYPE_CHARS(UV)];
2742 if (SvTYPE(sv) < SVt_PVIV)
2743 sv_upgrade(sv, SVt_PVIV);
2745 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2747 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2748 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2749 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2750 SvCUR_set(sv, ebuf - ptr);
2760 else if (SvNOKp(sv)) {
2761 if (SvTYPE(sv) < SVt_PVNV)
2762 sv_upgrade(sv, SVt_PVNV);
2763 /* The +20 is pure guesswork. Configure test needed. --jhi */
2764 SvGROW(sv, NV_DIG + 20);
2766 olderrno = errno; /* some Xenix systems wipe out errno here */
2768 if (SvNVX(sv) == 0.0)
2769 (void)strcpy(s,"0");
2773 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2776 #ifdef FIXNEGATIVEZERO
2777 if (*s == '-' && s[1] == '0' && !s[2])
2787 if (ckWARN(WARN_UNINITIALIZED)
2788 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2791 if (SvTYPE(sv) < SVt_PV)
2792 /* Typically the caller expects that sv_any is not NULL now. */
2793 sv_upgrade(sv, SVt_PV);
2796 *lp = s - SvPVX(sv);
2799 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2800 PTR2UV(sv),SvPVX(sv)));
2804 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2805 /* Sneaky stuff here */
2809 tsv = newSVpv(tmpbuf, 0);
2825 len = strlen(tmpbuf);
2827 #ifdef FIXNEGATIVEZERO
2828 if (len == 2 && t[0] == '-' && t[1] == '0') {
2833 (void)SvUPGRADE(sv, SVt_PV);
2835 s = SvGROW(sv, len + 1);
2844 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2847 return sv_2pvbyte(sv, &n_a);
2851 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2853 return sv_2pv(sv,lp);
2857 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2860 return sv_2pvutf8(sv, &n_a);
2864 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2866 sv_utf8_upgrade(sv);
2867 return SvPV(sv,*lp);
2870 /* This function is only called on magical items */
2872 Perl_sv_2bool(pTHX_ register SV *sv)
2881 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2882 (SvRV(tmpsv) != SvRV(sv)))
2883 return SvTRUE(tmpsv);
2884 return SvRV(sv) != 0;
2887 register XPV* Xpvtmp;
2888 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2889 (*Xpvtmp->xpv_pv > '0' ||
2890 Xpvtmp->xpv_cur > 1 ||
2891 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2898 return SvIVX(sv) != 0;
2901 return SvNVX(sv) != 0.0;
2909 =for apidoc sv_utf8_upgrade
2911 Convert the PV of an SV to its UTF8-encoded form.
2917 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2922 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2925 /* This function could be much more efficient if we had a FLAG in SVs
2926 * to signal if there are any hibit chars in the PV.
2927 * Given that there isn't make loop fast as possible
2933 if ((hibit = *t++ & 0x80))
2939 if (SvREADONLY(sv) && SvFAKE(sv)) {
2940 sv_force_normal(sv);
2943 len = SvCUR(sv) + 1; /* Plus the \0 */
2944 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2945 SvCUR(sv) = len - 1;
2947 Safefree(s); /* No longer using what was there before. */
2948 SvLEN(sv) = len; /* No longer know the real size. */
2954 =for apidoc sv_utf8_downgrade
2956 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2957 This may not be possible if the PV contains non-byte encoding characters;
2958 if this is the case, either returns false or, if C<fail_ok> is not
2965 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2967 if (SvPOK(sv) && SvUTF8(sv)) {
2969 char *c = SvPVX(sv);
2970 STRLEN len = SvCUR(sv);
2972 if (!utf8_to_bytes((U8*)c, &len)) {
2977 Perl_croak(aTHX_ "Wide character in %s",
2978 PL_op_desc[PL_op->op_type]);
2980 Perl_croak(aTHX_ "Wide character");
2992 =for apidoc sv_utf8_encode
2994 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2995 flag so that it looks like bytes again. Nothing calls this.
3001 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3003 sv_utf8_upgrade(sv);
3008 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3013 bool has_utf = FALSE;
3014 if (!sv_utf8_downgrade(sv, TRUE))
3017 /* it is actually just a matter of turning the utf8 flag on, but
3018 * we want to make sure everything inside is valid utf8 first.
3021 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
3035 /* Note: sv_setsv() should not be called with a source string that needs
3036 * to be reused, since it may destroy the source string if it is marked
3041 =for apidoc sv_setsv
3043 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3044 The source SV may be destroyed if it is mortal. Does not handle 'set'
3045 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3052 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3054 register U32 sflags;
3060 SV_CHECK_THINKFIRST(dstr);
3062 sstr = &PL_sv_undef;
3063 stype = SvTYPE(sstr);
3064 dtype = SvTYPE(dstr);
3068 /* There's a lot of redundancy below but we're going for speed here */
3073 if (dtype != SVt_PVGV) {
3074 (void)SvOK_off(dstr);
3082 sv_upgrade(dstr, SVt_IV);
3085 sv_upgrade(dstr, SVt_PVNV);
3089 sv_upgrade(dstr, SVt_PVIV);
3092 (void)SvIOK_only(dstr);
3093 SvIVX(dstr) = SvIVX(sstr);
3096 if (SvTAINTED(sstr))
3107 sv_upgrade(dstr, SVt_NV);
3112 sv_upgrade(dstr, SVt_PVNV);
3115 SvNVX(dstr) = SvNVX(sstr);
3116 (void)SvNOK_only(dstr);
3117 if (SvTAINTED(sstr))
3125 sv_upgrade(dstr, SVt_RV);
3126 else if (dtype == SVt_PVGV &&
3127 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3130 if (GvIMPORTED(dstr) != GVf_IMPORTED
3131 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3133 GvIMPORTED_on(dstr);
3144 sv_upgrade(dstr, SVt_PV);
3147 if (dtype < SVt_PVIV)
3148 sv_upgrade(dstr, SVt_PVIV);
3151 if (dtype < SVt_PVNV)
3152 sv_upgrade(dstr, SVt_PVNV);
3159 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3160 PL_op_name[PL_op->op_type]);
3162 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3166 if (dtype <= SVt_PVGV) {
3168 if (dtype != SVt_PVGV) {
3169 char *name = GvNAME(sstr);
3170 STRLEN len = GvNAMELEN(sstr);
3171 sv_upgrade(dstr, SVt_PVGV);
3172 sv_magic(dstr, dstr, '*', Nullch, 0);
3173 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3174 GvNAME(dstr) = savepvn(name, len);
3175 GvNAMELEN(dstr) = len;
3176 SvFAKE_on(dstr); /* can coerce to non-glob */
3178 /* ahem, death to those who redefine active sort subs */
3179 else if (PL_curstackinfo->si_type == PERLSI_SORT
3180 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3181 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3183 (void)SvOK_off(dstr);
3184 GvINTRO_off(dstr); /* one-shot flag */
3186 GvGP(dstr) = gp_ref(GvGP(sstr));
3187 if (SvTAINTED(sstr))
3189 if (GvIMPORTED(dstr) != GVf_IMPORTED
3190 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3192 GvIMPORTED_on(dstr);
3200 if (SvGMAGICAL(sstr)) {
3202 if (SvTYPE(sstr) != stype) {
3203 stype = SvTYPE(sstr);
3204 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3208 if (stype == SVt_PVLV)
3209 (void)SvUPGRADE(dstr, SVt_PVNV);
3211 (void)SvUPGRADE(dstr, stype);
3214 sflags = SvFLAGS(sstr);
3216 if (sflags & SVf_ROK) {
3217 if (dtype >= SVt_PV) {
3218 if (dtype == SVt_PVGV) {
3219 SV *sref = SvREFCNT_inc(SvRV(sstr));
3221 int intro = GvINTRO(dstr);
3226 GvINTRO_off(dstr); /* one-shot flag */
3227 Newz(602,gp, 1, GP);
3228 GvGP(dstr) = gp_ref(gp);
3229 GvSV(dstr) = NEWSV(72,0);
3230 GvLINE(dstr) = CopLINE(PL_curcop);
3231 GvEGV(dstr) = (GV*)dstr;
3234 switch (SvTYPE(sref)) {
3237 SAVESPTR(GvAV(dstr));
3239 dref = (SV*)GvAV(dstr);
3240 GvAV(dstr) = (AV*)sref;
3241 if (!GvIMPORTED_AV(dstr)
3242 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3244 GvIMPORTED_AV_on(dstr);
3249 SAVESPTR(GvHV(dstr));
3251 dref = (SV*)GvHV(dstr);
3252 GvHV(dstr) = (HV*)sref;
3253 if (!GvIMPORTED_HV(dstr)
3254 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3256 GvIMPORTED_HV_on(dstr);
3261 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3262 SvREFCNT_dec(GvCV(dstr));
3263 GvCV(dstr) = Nullcv;
3264 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3265 PL_sub_generation++;
3267 SAVESPTR(GvCV(dstr));
3270 dref = (SV*)GvCV(dstr);
3271 if (GvCV(dstr) != (CV*)sref) {
3272 CV* cv = GvCV(dstr);
3274 if (!GvCVGEN((GV*)dstr) &&
3275 (CvROOT(cv) || CvXSUB(cv)))
3278 /* ahem, death to those who redefine
3279 * active sort subs */
3280 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3281 PL_sortcop == CvSTART(cv))
3283 "Can't redefine active sort subroutine %s",
3284 GvENAME((GV*)dstr));
3285 /* Redefining a sub - warning is mandatory if
3286 it was a const and its value changed. */
3287 if (ckWARN(WARN_REDEFINE)
3289 && (!CvCONST((CV*)sref)
3290 || sv_cmp(cv_const_sv(cv),
3291 cv_const_sv((CV*)sref)))))
3293 Perl_warner(aTHX_ WARN_REDEFINE,
3295 ? "Constant subroutine %s redefined"
3296 : "Subroutine %s redefined",
3297 GvENAME((GV*)dstr));
3300 cv_ckproto(cv, (GV*)dstr,
3301 SvPOK(sref) ? SvPVX(sref) : Nullch);
3303 GvCV(dstr) = (CV*)sref;
3304 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3305 GvASSUMECV_on(dstr);
3306 PL_sub_generation++;
3308 if (!GvIMPORTED_CV(dstr)
3309 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3311 GvIMPORTED_CV_on(dstr);
3316 SAVESPTR(GvIOp(dstr));
3318 dref = (SV*)GvIOp(dstr);
3319 GvIOp(dstr) = (IO*)sref;
3323 SAVESPTR(GvFORM(dstr));
3325 dref = (SV*)GvFORM(dstr);
3326 GvFORM(dstr) = (CV*)sref;
3330 SAVESPTR(GvSV(dstr));
3332 dref = (SV*)GvSV(dstr);
3334 if (!GvIMPORTED_SV(dstr)
3335 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3337 GvIMPORTED_SV_on(dstr);
3345 if (SvTAINTED(sstr))
3350 (void)SvOOK_off(dstr); /* backoff */
3352 Safefree(SvPVX(dstr));
3353 SvLEN(dstr)=SvCUR(dstr)=0;
3356 (void)SvOK_off(dstr);
3357 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3359 if (sflags & SVp_NOK) {
3361 SvNVX(dstr) = SvNVX(sstr);
3363 if (sflags & SVp_IOK) {
3364 (void)SvIOK_on(dstr);
3365 SvIVX(dstr) = SvIVX(sstr);
3366 if (sflags & SVf_IVisUV)
3369 if (SvAMAGIC(sstr)) {
3373 else if (sflags & SVp_POK) {
3376 * Check to see if we can just swipe the string. If so, it's a
3377 * possible small lose on short strings, but a big win on long ones.
3378 * It might even be a win on short strings if SvPVX(dstr)
3379 * has to be allocated and SvPVX(sstr) has to be freed.
3382 if (SvTEMP(sstr) && /* slated for free anyway? */
3383 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3384 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3385 SvLEN(sstr) && /* and really is a string */
3386 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3388 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3390 SvFLAGS(dstr) &= ~SVf_OOK;
3391 Safefree(SvPVX(dstr) - SvIVX(dstr));
3393 else if (SvLEN(dstr))
3394 Safefree(SvPVX(dstr));
3396 (void)SvPOK_only(dstr);
3397 SvPV_set(dstr, SvPVX(sstr));
3398 SvLEN_set(dstr, SvLEN(sstr));
3399 SvCUR_set(dstr, SvCUR(sstr));
3402 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3403 SvPV_set(sstr, Nullch);
3408 else { /* have to copy actual string */
3409 STRLEN len = SvCUR(sstr);
3411 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3412 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3413 SvCUR_set(dstr, len);
3414 *SvEND(dstr) = '\0';
3415 (void)SvPOK_only(dstr);
3417 if ((sflags & SVf_UTF8) && !IN_BYTE)
3420 if (sflags & SVp_NOK) {
3422 SvNVX(dstr) = SvNVX(sstr);
3424 if (sflags & SVp_IOK) {
3425 (void)SvIOK_on(dstr);
3426 SvIVX(dstr) = SvIVX(sstr);
3427 if (sflags & SVf_IVisUV)
3431 else if (sflags & SVp_NOK) {
3432 SvNVX(dstr) = SvNVX(sstr);
3433 (void)SvNOK_only(dstr);
3434 if (sflags & SVf_IOK) {
3435 (void)SvIOK_on(dstr);
3436 SvIVX(dstr) = SvIVX(sstr);
3437 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3438 if (sflags & SVf_IVisUV)
3442 else if (sflags & SVp_IOK) {
3443 (void)SvIOK_only(dstr);
3444 SvIVX(dstr) = SvIVX(sstr);
3445 if (sflags & SVf_IVisUV)
3449 if (dtype == SVt_PVGV) {
3450 if (ckWARN(WARN_MISC))
3451 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3454 (void)SvOK_off(dstr);
3456 if (SvTAINTED(sstr))
3461 =for apidoc sv_setsv_mg
3463 Like C<sv_setsv>, but also handles 'set' magic.
3469 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3471 sv_setsv(dstr,sstr);
3476 =for apidoc sv_setpvn
3478 Copies a string into an SV. The C<len> parameter indicates the number of
3479 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3485 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3487 register char *dptr;
3489 /* len is STRLEN which is unsigned, need to copy to signed */
3493 SV_CHECK_THINKFIRST(sv);
3498 (void)SvUPGRADE(sv, SVt_PV);
3500 SvGROW(sv, len + 1);
3502 Move(ptr,dptr,len,char);
3505 (void)SvPOK_only(sv); /* validate pointer */
3510 =for apidoc sv_setpvn_mg
3512 Like C<sv_setpvn>, but also handles 'set' magic.
3518 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3520 sv_setpvn(sv,ptr,len);
3525 =for apidoc sv_setpv
3527 Copies a string into an SV. The string must be null-terminated. Does not
3528 handle 'set' magic. See C<sv_setpv_mg>.
3534 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3536 register STRLEN len;
3538 SV_CHECK_THINKFIRST(sv);
3544 (void)SvUPGRADE(sv, SVt_PV);
3546 SvGROW(sv, len + 1);
3547 Move(ptr,SvPVX(sv),len+1,char);
3549 (void)SvPOK_only(sv); /* validate pointer */
3554 =for apidoc sv_setpv_mg
3556 Like C<sv_setpv>, but also handles 'set' magic.
3562 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3569 =for apidoc sv_usepvn
3571 Tells an SV to use C<ptr> to find its string value. Normally the string is
3572 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3573 The C<ptr> should point to memory that was allocated by C<malloc>. The
3574 string length, C<len>, must be supplied. This function will realloc the
3575 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3576 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3577 See C<sv_usepvn_mg>.
3583 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3585 SV_CHECK_THINKFIRST(sv);
3586 (void)SvUPGRADE(sv, SVt_PV);
3591 (void)SvOOK_off(sv);
3592 if (SvPVX(sv) && SvLEN(sv))
3593 Safefree(SvPVX(sv));
3594 Renew(ptr, len+1, char);
3597 SvLEN_set(sv, len+1);
3599 (void)SvPOK_only(sv); /* validate pointer */
3604 =for apidoc sv_usepvn_mg
3606 Like C<sv_usepvn>, but also handles 'set' magic.
3612 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3614 sv_usepvn(sv,ptr,len);
3619 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3621 if (SvREADONLY(sv)) {
3623 char *pvx = SvPVX(sv);
3624 STRLEN len = SvCUR(sv);
3625 U32 hash = SvUVX(sv);
3626 SvGROW(sv, len + 1);
3627 Move(pvx,SvPVX(sv),len,char);
3631 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3633 else if (PL_curcop != &PL_compiling)
3634 Perl_croak(aTHX_ PL_no_modify);
3637 sv_unref_flags(sv, flags);
3638 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3643 Perl_sv_force_normal(pTHX_ register SV *sv)
3645 sv_force_normal_flags(sv, 0);
3651 Efficient removal of characters from the beginning of the string buffer.
3652 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3653 the string buffer. The C<ptr> becomes the first character of the adjusted
3660 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3664 register STRLEN delta;
3666 if (!ptr || !SvPOKp(sv))
3668 SV_CHECK_THINKFIRST(sv);
3669 if (SvTYPE(sv) < SVt_PVIV)
3670 sv_upgrade(sv,SVt_PVIV);
3673 if (!SvLEN(sv)) { /* make copy of shared string */
3674 char *pvx = SvPVX(sv);
3675 STRLEN len = SvCUR(sv);
3676 SvGROW(sv, len + 1);
3677 Move(pvx,SvPVX(sv),len,char);
3681 SvFLAGS(sv) |= SVf_OOK;
3683 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3684 delta = ptr - SvPVX(sv);
3692 =for apidoc sv_catpvn
3694 Concatenates the string onto the end of the string which is in the SV. The
3695 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3696 'set' magic. See C<sv_catpvn_mg>.
3702 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3707 junk = SvPV_force(sv, tlen);
3708 SvGROW(sv, tlen + len + 1);
3711 Move(ptr,SvPVX(sv)+tlen,len,char);
3714 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3719 =for apidoc sv_catpvn_mg
3721 Like C<sv_catpvn>, but also handles 'set' magic.
3727 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3729 sv_catpvn(sv,ptr,len);
3734 =for apidoc sv_catsv
3736 Concatenates the string from SV C<ssv> onto the end of the string in SV
3737 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3743 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3749 if ((s = SvPV(sstr, len))) {
3750 if (DO_UTF8(sstr)) {
3751 sv_utf8_upgrade(dstr);
3752 sv_catpvn(dstr,s,len);
3756 sv_catpvn(dstr,s,len);
3761 =for apidoc sv_catsv_mg
3763 Like C<sv_catsv>, but also handles 'set' magic.
3769 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3771 sv_catsv(dstr,sstr);
3776 =for apidoc sv_catpv
3778 Concatenates the string onto the end of the string which is in the SV.
3779 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3785 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3787 register STRLEN len;
3793 junk = SvPV_force(sv, tlen);
3795 SvGROW(sv, tlen + len + 1);
3798 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3800 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3805 =for apidoc sv_catpv_mg
3807 Like C<sv_catpv>, but also handles 'set' magic.
3813 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3820 Perl_newSV(pTHX_ STRLEN len)
3826 sv_upgrade(sv, SVt_PV);
3827 SvGROW(sv, len + 1);
3832 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3835 =for apidoc sv_magic
3837 Adds magic to an SV.
3843 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3847 if (SvREADONLY(sv)) {
3848 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3849 Perl_croak(aTHX_ PL_no_modify);
3851 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3852 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3859 (void)SvUPGRADE(sv, SVt_PVMG);
3861 Newz(702,mg, 1, MAGIC);
3862 mg->mg_moremagic = SvMAGIC(sv);
3865 if (!obj || obj == sv || how == '#' || how == 'r')
3868 mg->mg_obj = SvREFCNT_inc(obj);
3869 mg->mg_flags |= MGf_REFCOUNTED;
3872 mg->mg_len = namlen;
3875 mg->mg_ptr = savepvn(name, namlen);
3876 else if (namlen == HEf_SVKEY)
3877 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3881 mg->mg_virtual = &PL_vtbl_sv;
3884 mg->mg_virtual = &PL_vtbl_amagic;
3887 mg->mg_virtual = &PL_vtbl_amagicelem;
3893 mg->mg_virtual = &PL_vtbl_bm;
3896 mg->mg_virtual = &PL_vtbl_regdata;
3899 mg->mg_virtual = &PL_vtbl_regdatum;
3902 mg->mg_virtual = &PL_vtbl_env;
3905 mg->mg_virtual = &PL_vtbl_fm;
3908 mg->mg_virtual = &PL_vtbl_envelem;
3911 mg->mg_virtual = &PL_vtbl_mglob;
3914 mg->mg_virtual = &PL_vtbl_isa;
3917 mg->mg_virtual = &PL_vtbl_isaelem;
3920 mg->mg_virtual = &PL_vtbl_nkeys;
3927 mg->mg_virtual = &PL_vtbl_dbline;
3931 mg->mg_virtual = &PL_vtbl_mutex;
3933 #endif /* USE_THREADS */
3934 #ifdef USE_LOCALE_COLLATE
3936 mg->mg_virtual = &PL_vtbl_collxfrm;
3938 #endif /* USE_LOCALE_COLLATE */
3940 mg->mg_virtual = &PL_vtbl_pack;
3944 mg->mg_virtual = &PL_vtbl_packelem;
3947 mg->mg_virtual = &PL_vtbl_regexp;
3950 mg->mg_virtual = &PL_vtbl_sig;
3953 mg->mg_virtual = &PL_vtbl_sigelem;
3956 mg->mg_virtual = &PL_vtbl_taint;
3960 mg->mg_virtual = &PL_vtbl_uvar;
3963 mg->mg_virtual = &PL_vtbl_vec;
3966 mg->mg_virtual = &PL_vtbl_substr;
3969 mg->mg_virtual = &PL_vtbl_defelem;
3972 mg->mg_virtual = &PL_vtbl_glob;
3975 mg->mg_virtual = &PL_vtbl_arylen;
3978 mg->mg_virtual = &PL_vtbl_pos;
3981 mg->mg_virtual = &PL_vtbl_backref;
3983 case '~': /* Reserved for use by extensions not perl internals. */
3984 /* Useful for attaching extension internal data to perl vars. */
3985 /* Note that multiple extensions may clash if magical scalars */
3986 /* etc holding private data from one are passed to another. */
3990 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3994 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3998 =for apidoc sv_unmagic
4000 Removes magic from an SV.
4006 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4010 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4013 for (mg = *mgp; mg; mg = *mgp) {
4014 if (mg->mg_type == type) {
4015 MGVTBL* vtbl = mg->mg_virtual;
4016 *mgp = mg->mg_moremagic;
4017 if (vtbl && vtbl->svt_free)
4018 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4019 if (mg->mg_ptr && mg->mg_type != 'g')
4020 if (mg->mg_len >= 0)
4021 Safefree(mg->mg_ptr);
4022 else if (mg->mg_len == HEf_SVKEY)
4023 SvREFCNT_dec((SV*)mg->mg_ptr);
4024 if (mg->mg_flags & MGf_REFCOUNTED)
4025 SvREFCNT_dec(mg->mg_obj);
4029 mgp = &mg->mg_moremagic;
4033 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4040 =for apidoc sv_rvweaken
4048 Perl_sv_rvweaken(pTHX_ SV *sv)
4051 if (!SvOK(sv)) /* let undefs pass */
4054 Perl_croak(aTHX_ "Can't weaken a nonreference");
4055 else if (SvWEAKREF(sv)) {
4056 if (ckWARN(WARN_MISC))
4057 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4061 sv_add_backref(tsv, sv);
4068 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4072 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4073 av = (AV*)mg->mg_obj;
4076 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4077 SvREFCNT_dec(av); /* for sv_magic */
4083 S_sv_del_backref(pTHX_ SV *sv)
4090 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4091 Perl_croak(aTHX_ "panic: del_backref");
4092 av = (AV *)mg->mg_obj;
4097 svp[i] = &PL_sv_undef; /* XXX */
4104 =for apidoc sv_insert
4106 Inserts a string at the specified offset/length within the SV. Similar to
4107 the Perl substr() function.
4113 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4117 register char *midend;
4118 register char *bigend;
4124 Perl_croak(aTHX_ "Can't modify non-existent substring");
4125 SvPV_force(bigstr, curlen);
4126 (void)SvPOK_only_UTF8(bigstr);
4127 if (offset + len > curlen) {
4128 SvGROW(bigstr, offset+len+1);
4129 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4130 SvCUR_set(bigstr, offset+len);
4134 i = littlelen - len;
4135 if (i > 0) { /* string might grow */
4136 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4137 mid = big + offset + len;
4138 midend = bigend = big + SvCUR(bigstr);
4141 while (midend > mid) /* shove everything down */
4142 *--bigend = *--midend;
4143 Move(little,big+offset,littlelen,char);
4149 Move(little,SvPVX(bigstr)+offset,len,char);
4154 big = SvPVX(bigstr);
4157 bigend = big + SvCUR(bigstr);
4159 if (midend > bigend)
4160 Perl_croak(aTHX_ "panic: sv_insert");
4162 if (mid - big > bigend - midend) { /* faster to shorten from end */
4164 Move(little, mid, littlelen,char);
4167 i = bigend - midend;
4169 Move(midend, mid, i,char);
4173 SvCUR_set(bigstr, mid - big);
4176 else if ((i = mid - big)) { /* faster from front */
4177 midend -= littlelen;
4179 sv_chop(bigstr,midend-i);
4184 Move(little, mid, littlelen,char);
4186 else if (littlelen) {
4187 midend -= littlelen;
4188 sv_chop(bigstr,midend);
4189 Move(little,midend,littlelen,char);
4192 sv_chop(bigstr,midend);
4198 =for apidoc sv_replace
4200 Make the first argument a copy of the second, then delete the original.
4206 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4208 U32 refcnt = SvREFCNT(sv);
4209 SV_CHECK_THINKFIRST(sv);
4210 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4211 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4212 if (SvMAGICAL(sv)) {
4216 sv_upgrade(nsv, SVt_PVMG);
4217 SvMAGIC(nsv) = SvMAGIC(sv);
4218 SvFLAGS(nsv) |= SvMAGICAL(sv);
4224 assert(!SvREFCNT(sv));
4225 StructCopy(nsv,sv,SV);
4226 SvREFCNT(sv) = refcnt;
4227 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4232 =for apidoc sv_clear
4234 Clear an SV, making it empty. Does not free the memory used by the SV
4241 Perl_sv_clear(pTHX_ register SV *sv)
4245 assert(SvREFCNT(sv) == 0);
4248 if (PL_defstash) { /* Still have a symbol table? */
4253 Zero(&tmpref, 1, SV);
4254 sv_upgrade(&tmpref, SVt_RV);
4256 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4257 SvREFCNT(&tmpref) = 1;
4260 stash = SvSTASH(sv);
4261 destructor = StashHANDLER(stash,DESTROY);
4264 PUSHSTACKi(PERLSI_DESTROY);
4265 SvRV(&tmpref) = SvREFCNT_inc(sv);
4270 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4276 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4278 del_XRV(SvANY(&tmpref));
4281 if (PL_in_clean_objs)
4282 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4284 /* DESTROY gave object new lease on life */
4290 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4291 SvOBJECT_off(sv); /* Curse the object. */
4292 if (SvTYPE(sv) != SVt_PVIO)
4293 --PL_sv_objcount; /* XXX Might want something more general */
4296 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4299 switch (SvTYPE(sv)) {
4302 IoIFP(sv) != PerlIO_stdin() &&
4303 IoIFP(sv) != PerlIO_stdout() &&
4304 IoIFP(sv) != PerlIO_stderr())
4306 io_close((IO*)sv, FALSE);
4308 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4309 PerlDir_close(IoDIRP(sv));
4310 IoDIRP(sv) = (DIR*)NULL;
4311 Safefree(IoTOP_NAME(sv));
4312 Safefree(IoFMT_NAME(sv));
4313 Safefree(IoBOTTOM_NAME(sv));
4328 SvREFCNT_dec(LvTARG(sv));
4332 Safefree(GvNAME(sv));
4333 /* cannot decrease stash refcount yet, as we might recursively delete
4334 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4335 of stash until current sv is completely gone.
4336 -- JohnPC, 27 Mar 1998 */
4337 stash = GvSTASH(sv);
4343 (void)SvOOK_off(sv);
4351 SvREFCNT_dec(SvRV(sv));
4353 else if (SvPVX(sv) && SvLEN(sv))
4354 Safefree(SvPVX(sv));
4355 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4356 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4368 switch (SvTYPE(sv)) {
4384 del_XPVIV(SvANY(sv));
4387 del_XPVNV(SvANY(sv));
4390 del_XPVMG(SvANY(sv));
4393 del_XPVLV(SvANY(sv));
4396 del_XPVAV(SvANY(sv));
4399 del_XPVHV(SvANY(sv));
4402 del_XPVCV(SvANY(sv));
4405 del_XPVGV(SvANY(sv));
4406 /* code duplication for increased performance. */
4407 SvFLAGS(sv) &= SVf_BREAK;
4408 SvFLAGS(sv) |= SVTYPEMASK;
4409 /* decrease refcount of the stash that owns this GV, if any */
4411 SvREFCNT_dec(stash);
4412 return; /* not break, SvFLAGS reset already happened */
4414 del_XPVBM(SvANY(sv));
4417 del_XPVFM(SvANY(sv));
4420 del_XPVIO(SvANY(sv));
4423 SvFLAGS(sv) &= SVf_BREAK;
4424 SvFLAGS(sv) |= SVTYPEMASK;
4428 Perl_sv_newref(pTHX_ SV *sv)
4431 ATOMIC_INC(SvREFCNT(sv));
4438 Free the memory used by an SV.
4444 Perl_sv_free(pTHX_ SV *sv)
4446 int refcount_is_zero;
4450 if (SvREFCNT(sv) == 0) {
4451 if (SvFLAGS(sv) & SVf_BREAK)
4453 if (PL_in_clean_all) /* All is fair */
4455 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4456 /* make sure SvREFCNT(sv)==0 happens very seldom */
4457 SvREFCNT(sv) = (~(U32)0)/2;
4460 if (ckWARN_d(WARN_INTERNAL))
4461 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4464 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4465 if (!refcount_is_zero)
4469 if (ckWARN_d(WARN_DEBUGGING))
4470 Perl_warner(aTHX_ WARN_DEBUGGING,
4471 "Attempt to free temp prematurely: SV 0x%"UVxf,
4476 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4477 /* make sure SvREFCNT(sv)==0 happens very seldom */
4478 SvREFCNT(sv) = (~(U32)0)/2;
4489 Returns the length of the string in the SV. See also C<SvCUR>.
4495 Perl_sv_len(pTHX_ register SV *sv)
4504 len = mg_length(sv);
4506 junk = SvPV(sv, len);
4511 =for apidoc sv_len_utf8
4513 Returns the number of characters in the string in an SV, counting wide
4514 UTF8 bytes as a single character.
4520 Perl_sv_len_utf8(pTHX_ register SV *sv)
4526 return mg_length(sv);
4530 U8 *s = (U8*)SvPV(sv, len);
4532 return Perl_utf8_length(aTHX_ s, s + len);
4537 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4542 I32 uoffset = *offsetp;
4548 start = s = (U8*)SvPV(sv, len);
4550 while (s < send && uoffset--)
4554 *offsetp = s - start;
4558 while (s < send && ulen--)
4568 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4577 s = (U8*)SvPV(sv, len);
4579 Perl_croak(aTHX_ "panic: bad byte offset");
4580 send = s + *offsetp;
4587 if (ckWARN_d(WARN_UTF8))
4588 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4598 Returns a boolean indicating whether the strings in the two SVs are
4605 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4612 bool pv1tmp = FALSE;
4613 bool pv2tmp = FALSE;
4620 pv1 = SvPV(sv1, cur1);
4627 pv2 = SvPV(sv2, cur2);
4629 /* do not utf8ize the comparands as a side-effect */
4630 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4632 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4636 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4642 eq = memEQ(pv1, pv2, cur1);
4655 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4656 string in C<sv1> is less than, equal to, or greater than the string in
4663 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4668 bool pv1tmp = FALSE;
4669 bool pv2tmp = FALSE;
4676 pv1 = SvPV(sv1, cur1);
4683 pv2 = SvPV(sv2, cur2);
4685 /* do not utf8ize the comparands as a side-effect */
4686 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4688 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4692 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4698 cmp = cur2 ? -1 : 0;
4702 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4705 cmp = retval < 0 ? -1 : 1;
4706 } else if (cur1 == cur2) {
4709 cmp = cur1 < cur2 ? -1 : 1;
4722 =for apidoc sv_cmp_locale
4724 Compares the strings in two SVs in a locale-aware manner. See
4731 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4733 #ifdef USE_LOCALE_COLLATE
4739 if (PL_collation_standard)
4743 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4745 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4747 if (!pv1 || !len1) {
4758 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4761 return retval < 0 ? -1 : 1;
4764 * When the result of collation is equality, that doesn't mean
4765 * that there are no differences -- some locales exclude some
4766 * characters from consideration. So to avoid false equalities,
4767 * we use the raw string as a tiebreaker.
4773 #endif /* USE_LOCALE_COLLATE */
4775 return sv_cmp(sv1, sv2);
4778 #ifdef USE_LOCALE_COLLATE
4780 * Any scalar variable may carry an 'o' magic that contains the
4781 * scalar data of the variable transformed to such a format that
4782 * a normal memory comparison can be used to compare the data
4783 * according to the locale settings.
4786 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4790 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4791 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4796 Safefree(mg->mg_ptr);
4798 if ((xf = mem_collxfrm(s, len, &xlen))) {
4799 if (SvREADONLY(sv)) {
4802 return xf + sizeof(PL_collation_ix);
4805 sv_magic(sv, 0, 'o', 0, 0);
4806 mg = mg_find(sv, 'o');
4819 if (mg && mg->mg_ptr) {
4821 return mg->mg_ptr + sizeof(PL_collation_ix);
4829 #endif /* USE_LOCALE_COLLATE */
4834 Get a line from the filehandle and store it into the SV, optionally
4835 appending to the currently-stored string.
4841 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4845 register STDCHAR rslast;
4846 register STDCHAR *bp;
4850 SV_CHECK_THINKFIRST(sv);
4851 (void)SvUPGRADE(sv, SVt_PV);
4855 if (RsSNARF(PL_rs)) {
4859 else if (RsRECORD(PL_rs)) {
4860 I32 recsize, bytesread;
4863 /* Grab the size of the record we're getting */
4864 recsize = SvIV(SvRV(PL_rs));
4865 (void)SvPOK_only(sv); /* Validate pointer */
4866 buffer = SvGROW(sv, recsize + 1);
4869 /* VMS wants read instead of fread, because fread doesn't respect */
4870 /* RMS record boundaries. This is not necessarily a good thing to be */
4871 /* doing, but we've got no other real choice */
4872 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4874 bytesread = PerlIO_read(fp, buffer, recsize);
4876 SvCUR_set(sv, bytesread);
4877 buffer[bytesread] = '\0';
4878 if (PerlIO_isutf8(fp))
4882 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4884 else if (RsPARA(PL_rs)) {
4889 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4890 if (PerlIO_isutf8(fp)) {
4891 rsptr = SvPVutf8(PL_rs, rslen);
4894 if (SvUTF8(PL_rs)) {
4895 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4896 Perl_croak(aTHX_ "Wide character in $/");
4899 rsptr = SvPV(PL_rs, rslen);
4903 rslast = rslen ? rsptr[rslen - 1] : '\0';
4905 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4906 do { /* to make sure file boundaries work right */
4909 i = PerlIO_getc(fp);
4913 PerlIO_ungetc(fp,i);
4919 /* See if we know enough about I/O mechanism to cheat it ! */
4921 /* This used to be #ifdef test - it is made run-time test for ease
4922 of abstracting out stdio interface. One call should be cheap
4923 enough here - and may even be a macro allowing compile
4927 if (PerlIO_fast_gets(fp)) {
4930 * We're going to steal some values from the stdio struct
4931 * and put EVERYTHING in the innermost loop into registers.
4933 register STDCHAR *ptr;
4937 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4938 /* An ungetc()d char is handled separately from the regular
4939 * buffer, so we getc() it back out and stuff it in the buffer.
4941 i = PerlIO_getc(fp);
4942 if (i == EOF) return 0;
4943 *(--((*fp)->_ptr)) = (unsigned char) i;
4947 /* Here is some breathtakingly efficient cheating */
4949 cnt = PerlIO_get_cnt(fp); /* get count into register */
4950 (void)SvPOK_only(sv); /* validate pointer */
4951 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4952 if (cnt > 80 && SvLEN(sv) > append) {
4953 shortbuffered = cnt - SvLEN(sv) + append + 1;
4954 cnt -= shortbuffered;
4958 /* remember that cnt can be negative */
4959 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4964 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4965 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4966 DEBUG_P(PerlIO_printf(Perl_debug_log,
4967 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4968 DEBUG_P(PerlIO_printf(Perl_debug_log,
4969 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4970 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4971 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4976 while (cnt > 0) { /* this | eat */
4978 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4979 goto thats_all_folks; /* screams | sed :-) */
4983 Copy(ptr, bp, cnt, char); /* this | eat */
4984 bp += cnt; /* screams | dust */
4985 ptr += cnt; /* louder | sed :-) */
4990 if (shortbuffered) { /* oh well, must extend */
4991 cnt = shortbuffered;
4993 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4995 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4996 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5000 DEBUG_P(PerlIO_printf(Perl_debug_log,
5001 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5002 PTR2UV(ptr),(long)cnt));
5003 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5004 DEBUG_P(PerlIO_printf(Perl_debug_log,
5005 "Screamer: pre: 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 /* This used to call 'filbuf' in stdio form, but as that behaves like
5009 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5010 another abstraction. */
5011 i = PerlIO_getc(fp); /* get more characters */
5012 DEBUG_P(PerlIO_printf(Perl_debug_log,
5013 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5014 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5015 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5016 cnt = PerlIO_get_cnt(fp);
5017 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5018 DEBUG_P(PerlIO_printf(Perl_debug_log,
5019 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5021 if (i == EOF) /* all done for ever? */
5022 goto thats_really_all_folks;
5024 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5026 SvGROW(sv, bpx + cnt + 2);
5027 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5029 *bp++ = i; /* store character from PerlIO_getc */
5031 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5032 goto thats_all_folks;
5036 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5037 memNE((char*)bp - rslen, rsptr, rslen))
5038 goto screamer; /* go back to the fray */
5039 thats_really_all_folks:
5041 cnt += shortbuffered;
5042 DEBUG_P(PerlIO_printf(Perl_debug_log,
5043 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5044 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5045 DEBUG_P(PerlIO_printf(Perl_debug_log,
5046 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5047 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5048 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5050 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5051 DEBUG_P(PerlIO_printf(Perl_debug_log,
5052 "Screamer: done, len=%ld, string=|%.*s|\n",
5053 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5058 /*The big, slow, and stupid way */
5061 /* Need to work around EPOC SDK features */
5062 /* On WINS: MS VC5 generates calls to _chkstk, */
5063 /* if a `large' stack frame is allocated */
5064 /* gcc on MARM does not generate calls like these */
5070 register STDCHAR *bpe = buf + sizeof(buf);
5072 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5073 ; /* keep reading */
5077 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5078 /* Accomodate broken VAXC compiler, which applies U8 cast to
5079 * both args of ?: operator, causing EOF to change into 255
5081 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5085 sv_catpvn(sv, (char *) buf, cnt);
5087 sv_setpvn(sv, (char *) buf, cnt);
5089 if (i != EOF && /* joy */
5091 SvCUR(sv) < rslen ||
5092 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5096 * If we're reading from a TTY and we get a short read,
5097 * indicating that the user hit his EOF character, we need
5098 * to notice it now, because if we try to read from the TTY
5099 * again, the EOF condition will disappear.
5101 * The comparison of cnt to sizeof(buf) is an optimization
5102 * that prevents unnecessary calls to feof().
5106 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5111 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5112 while (i != EOF) { /* to make sure file boundaries work right */
5113 i = PerlIO_getc(fp);
5115 PerlIO_ungetc(fp,i);
5121 if (PerlIO_isutf8(fp))
5126 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5133 Auto-increment of the value in the SV.
5139 Perl_sv_inc(pTHX_ register SV *sv)
5148 if (SvTHINKFIRST(sv)) {
5149 if (SvREADONLY(sv)) {
5150 if (PL_curcop != &PL_compiling)
5151 Perl_croak(aTHX_ PL_no_modify);
5155 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5157 i = PTR2IV(SvRV(sv));
5162 flags = SvFLAGS(sv);
5163 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5164 /* It's (privately or publicly) a float, but not tested as an
5165 integer, so test it to see. */
5167 flags = SvFLAGS(sv);
5169 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5170 /* It's publicly an integer, or privately an integer-not-float */
5173 if (SvUVX(sv) == UV_MAX)
5174 sv_setnv(sv, (NV)UV_MAX + 1.0);
5176 (void)SvIOK_only_UV(sv);
5179 if (SvIVX(sv) == IV_MAX)
5180 sv_setuv(sv, (UV)IV_MAX + 1);
5182 (void)SvIOK_only(sv);
5188 if (flags & SVp_NOK) {
5189 (void)SvNOK_only(sv);
5194 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5195 if ((flags & SVTYPEMASK) < SVt_PVIV)
5196 sv_upgrade(sv, SVt_IV);
5197 (void)SvIOK_only(sv);
5202 while (isALPHA(*d)) d++;
5203 while (isDIGIT(*d)) d++;
5205 #ifdef PERL_PRESERVE_IVUV
5206 /* Got to punt this an an integer if needs be, but we don't issue
5207 warnings. Probably ought to make the sv_iv_please() that does
5208 the conversion if possible, and silently. */
5209 I32 numtype = looks_like_number(sv);
5210 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5211 /* Need to try really hard to see if it's an integer.
5212 9.22337203685478e+18 is an integer.
5213 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5214 so $a="9.22337203685478e+18"; $a+0; $a++
5215 needs to be the same as $a="9.22337203685478e+18"; $a++
5222 /* sv_2iv *should* have made this an NV */
5223 if (flags & SVp_NOK) {
5224 (void)SvNOK_only(sv);
5228 /* I don't think we can get here. Maybe I should assert this
5229 And if we do get here I suspect that sv_setnv will croak. NWC
5231 #if defined(USE_LONG_DOUBLE)
5232 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",
5233 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5235 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5236 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5239 #endif /* PERL_PRESERVE_IVUV */
5240 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5244 while (d >= SvPVX(sv)) {
5252 /* MKS: The original code here died if letters weren't consecutive.
5253 * at least it didn't have to worry about non-C locales. The
5254 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5255 * arranged in order (although not consecutively) and that only
5256 * [A-Za-z] are accepted by isALPHA in the C locale.
5258 if (*d != 'z' && *d != 'Z') {
5259 do { ++*d; } while (!isALPHA(*d));
5262 *(d--) -= 'z' - 'a';
5267 *(d--) -= 'z' - 'a' + 1;
5271 /* oh,oh, the number grew */
5272 SvGROW(sv, SvCUR(sv) + 2);
5274 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5285 Auto-decrement of the value in the SV.
5291 Perl_sv_dec(pTHX_ register SV *sv)
5299 if (SvTHINKFIRST(sv)) {
5300 if (SvREADONLY(sv)) {
5301 if (PL_curcop != &PL_compiling)
5302 Perl_croak(aTHX_ PL_no_modify);
5306 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5308 i = PTR2IV(SvRV(sv));
5313 /* Unlike sv_inc we don't have to worry about string-never-numbers
5314 and keeping them magic. But we mustn't warn on punting */
5315 flags = SvFLAGS(sv);
5316 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5317 /* It's publicly an integer, or privately an integer-not-float */
5320 if (SvUVX(sv) == 0) {
5321 (void)SvIOK_only(sv);
5325 (void)SvIOK_only_UV(sv);
5329 if (SvIVX(sv) == IV_MIN)
5330 sv_setnv(sv, (NV)IV_MIN - 1.0);
5332 (void)SvIOK_only(sv);
5338 if (flags & SVp_NOK) {
5340 (void)SvNOK_only(sv);
5343 if (!(flags & SVp_POK)) {
5344 if ((flags & SVTYPEMASK) < SVt_PVNV)
5345 sv_upgrade(sv, SVt_NV);
5347 (void)SvNOK_only(sv);
5350 #ifdef PERL_PRESERVE_IVUV
5352 I32 numtype = looks_like_number(sv);
5353 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5354 /* Need to try really hard to see if it's an integer.
5355 9.22337203685478e+18 is an integer.
5356 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5357 so $a="9.22337203685478e+18"; $a+0; $a--
5358 needs to be the same as $a="9.22337203685478e+18"; $a--
5365 /* sv_2iv *should* have made this an NV */
5366 if (flags & SVp_NOK) {
5367 (void)SvNOK_only(sv);
5371 /* I don't think we can get here. Maybe I should assert this
5372 And if we do get here I suspect that sv_setnv will croak. NWC
5374 #if defined(USE_LONG_DOUBLE)
5375 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",
5376 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5378 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5379 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5383 #endif /* PERL_PRESERVE_IVUV */
5384 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5388 =for apidoc sv_mortalcopy
5390 Creates a new SV which is a copy of the original SV. The new SV is marked
5396 /* Make a string that will exist for the duration of the expression
5397 * evaluation. Actually, it may have to last longer than that, but
5398 * hopefully we won't free it until it has been assigned to a
5399 * permanent location. */
5402 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5407 sv_setsv(sv,oldstr);
5409 PL_tmps_stack[++PL_tmps_ix] = sv;
5415 =for apidoc sv_newmortal
5417 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5423 Perl_sv_newmortal(pTHX)
5428 SvFLAGS(sv) = SVs_TEMP;
5430 PL_tmps_stack[++PL_tmps_ix] = sv;
5435 =for apidoc sv_2mortal
5437 Marks an SV as mortal. The SV will be destroyed when the current context
5443 /* same thing without the copying */
5446 Perl_sv_2mortal(pTHX_ register SV *sv)
5450 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5453 PL_tmps_stack[++PL_tmps_ix] = sv;
5461 Creates a new SV and copies a string into it. The reference count for the
5462 SV is set to 1. If C<len> is zero, Perl will compute the length using
5463 strlen(). For efficiency, consider using C<newSVpvn> instead.
5469 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5476 sv_setpvn(sv,s,len);
5481 =for apidoc newSVpvn
5483 Creates a new SV and copies a string into it. The reference count for the
5484 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5485 string. You are responsible for ensuring that the source string is at least
5492 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5497 sv_setpvn(sv,s,len);
5502 =for apidoc newSVpvn_share
5504 Creates a new SV and populates it with a string from
5505 the string table. Turns on READONLY and FAKE.
5506 The idea here is that as string table is used for shared hash
5507 keys these strings will have SvPVX == HeKEY and hash lookup
5508 will avoid string compare.
5514 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5517 bool is_utf8 = FALSE;
5523 PERL_HASH(hash, src, len);
5525 sv_upgrade(sv, SVt_PVIV);
5526 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5538 #if defined(PERL_IMPLICIT_CONTEXT)
5540 Perl_newSVpvf_nocontext(const char* pat, ...)
5545 va_start(args, pat);
5546 sv = vnewSVpvf(pat, &args);
5553 =for apidoc newSVpvf
5555 Creates a new SV an initialize it with the string formatted like
5562 Perl_newSVpvf(pTHX_ const char* pat, ...)
5566 va_start(args, pat);
5567 sv = vnewSVpvf(pat, &args);
5573 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5577 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5584 Creates a new SV and copies a floating point value into it.
5585 The reference count for the SV is set to 1.
5591 Perl_newSVnv(pTHX_ NV n)
5603 Creates a new SV and copies an integer into it. The reference count for the
5610 Perl_newSViv(pTHX_ IV i)
5622 Creates a new SV and copies an unsigned integer into it.
5623 The reference count for the SV is set to 1.
5629 Perl_newSVuv(pTHX_ UV u)
5639 =for apidoc newRV_noinc
5641 Creates an RV wrapper for an SV. The reference count for the original
5642 SV is B<not> incremented.
5648 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5653 sv_upgrade(sv, SVt_RV);
5660 /* newRV_inc is #defined to newRV in sv.h */
5662 Perl_newRV(pTHX_ SV *tmpRef)
5664 return newRV_noinc(SvREFCNT_inc(tmpRef));
5670 Creates a new SV which is an exact duplicate of the original SV.
5675 /* make an exact duplicate of old */
5678 Perl_newSVsv(pTHX_ register SV *old)
5684 if (SvTYPE(old) == SVTYPEMASK) {
5685 if (ckWARN_d(WARN_INTERNAL))
5686 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5701 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5709 char todo[PERL_UCHAR_MAX+1];
5714 if (!*s) { /* reset ?? searches */
5715 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5716 pm->op_pmdynflags &= ~PMdf_USED;
5721 /* reset variables */
5723 if (!HvARRAY(stash))
5726 Zero(todo, 256, char);
5728 i = (unsigned char)*s;
5732 max = (unsigned char)*s++;
5733 for ( ; i <= max; i++) {
5736 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5737 for (entry = HvARRAY(stash)[i];
5739 entry = HeNEXT(entry))
5741 if (!todo[(U8)*HeKEY(entry)])
5743 gv = (GV*)HeVAL(entry);
5745 if (SvTHINKFIRST(sv)) {
5746 if (!SvREADONLY(sv) && SvROK(sv))
5751 if (SvTYPE(sv) >= SVt_PV) {
5753 if (SvPVX(sv) != Nullch)
5760 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5762 #ifdef USE_ENVIRON_ARRAY
5764 environ[0] = Nullch;
5773 Perl_sv_2io(pTHX_ SV *sv)
5779 switch (SvTYPE(sv)) {
5787 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5791 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5793 return sv_2io(SvRV(sv));
5794 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5800 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5807 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5814 return *gvp = Nullgv, Nullcv;
5815 switch (SvTYPE(sv)) {
5834 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5835 tryAMAGICunDEREF(to_cv);
5838 if (SvTYPE(sv) == SVt_PVCV) {
5847 Perl_croak(aTHX_ "Not a subroutine reference");
5852 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5858 if (lref && !GvCVu(gv)) {
5861 tmpsv = NEWSV(704,0);
5862 gv_efullname3(tmpsv, gv, Nullch);
5863 /* XXX this is probably not what they think they're getting.
5864 * It has the same effect as "sub name;", i.e. just a forward
5866 newSUB(start_subparse(FALSE, 0),
5867 newSVOP(OP_CONST, 0, tmpsv),
5872 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5881 Returns true if the SV has a true value by Perl's rules.
5887 Perl_sv_true(pTHX_ register SV *sv)
5893 if ((tXpv = (XPV*)SvANY(sv)) &&
5894 (tXpv->xpv_cur > 1 ||
5895 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5902 return SvIVX(sv) != 0;
5905 return SvNVX(sv) != 0.0;
5907 return sv_2bool(sv);
5913 Perl_sv_iv(pTHX_ register SV *sv)
5917 return (IV)SvUVX(sv);
5924 Perl_sv_uv(pTHX_ register SV *sv)
5929 return (UV)SvIVX(sv);
5935 Perl_sv_nv(pTHX_ register SV *sv)
5943 Perl_sv_pv(pTHX_ SV *sv)
5950 return sv_2pv(sv, &n_a);
5954 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5960 return sv_2pv(sv, lp);
5964 =for apidoc sv_pvn_force
5966 Get a sensible string out of the SV somehow.
5972 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5976 if (SvTHINKFIRST(sv) && !SvROK(sv))
5977 sv_force_normal(sv);
5983 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5984 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5985 PL_op_name[PL_op->op_type]);
5989 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5994 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5995 SvGROW(sv, len + 1);
5996 Move(s,SvPVX(sv),len,char);
6001 SvPOK_on(sv); /* validate pointer */
6003 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6004 PTR2UV(sv),SvPVX(sv)));
6011 Perl_sv_pvbyte(pTHX_ SV *sv)
6017 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6019 return sv_pvn(sv,lp);
6023 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6025 return sv_pvn_force(sv,lp);
6029 Perl_sv_pvutf8(pTHX_ SV *sv)
6031 sv_utf8_upgrade(sv);
6036 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6038 sv_utf8_upgrade(sv);
6039 return sv_pvn(sv,lp);
6043 =for apidoc sv_pvutf8n_force
6045 Get a sensible UTF8-encoded string out of the SV somehow. See
6052 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6054 sv_utf8_upgrade(sv);
6055 return sv_pvn_force(sv,lp);
6059 =for apidoc sv_reftype
6061 Returns a string describing what the SV is a reference to.
6067 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6069 if (ob && SvOBJECT(sv))
6070 return HvNAME(SvSTASH(sv));
6072 switch (SvTYPE(sv)) {
6086 case SVt_PVLV: return "LVALUE";
6087 case SVt_PVAV: return "ARRAY";
6088 case SVt_PVHV: return "HASH";
6089 case SVt_PVCV: return "CODE";
6090 case SVt_PVGV: return "GLOB";
6091 case SVt_PVFM: return "FORMAT";
6092 case SVt_PVIO: return "IO";
6093 default: return "UNKNOWN";
6099 =for apidoc sv_isobject
6101 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6102 object. If the SV is not an RV, or if the object is not blessed, then this
6109 Perl_sv_isobject(pTHX_ SV *sv)
6126 Returns a boolean indicating whether the SV is blessed into the specified
6127 class. This does not check for subtypes; use C<sv_derived_from> to verify
6128 an inheritance relationship.
6134 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6146 return strEQ(HvNAME(SvSTASH(sv)), name);
6152 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6153 it will be upgraded to one. If C<classname> is non-null then the new SV will
6154 be blessed in the specified package. The new SV is returned and its
6155 reference count is 1.
6161 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6167 SV_CHECK_THINKFIRST(rv);
6170 if (SvTYPE(rv) >= SVt_PVMG) {
6171 U32 refcnt = SvREFCNT(rv);
6175 SvREFCNT(rv) = refcnt;
6178 if (SvTYPE(rv) < SVt_RV)
6179 sv_upgrade(rv, SVt_RV);
6180 else if (SvTYPE(rv) > SVt_RV) {
6181 (void)SvOOK_off(rv);
6182 if (SvPVX(rv) && SvLEN(rv))
6183 Safefree(SvPVX(rv));
6193 HV* stash = gv_stashpv(classname, TRUE);
6194 (void)sv_bless(rv, stash);
6200 =for apidoc sv_setref_pv
6202 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6203 argument will be upgraded to an RV. That RV will be modified to point to
6204 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6205 into the SV. The C<classname> argument indicates the package for the
6206 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6207 will be returned and will have a reference count of 1.
6209 Do not use with other Perl types such as HV, AV, SV, CV, because those
6210 objects will become corrupted by the pointer copy process.
6212 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6218 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6221 sv_setsv(rv, &PL_sv_undef);
6225 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6230 =for apidoc sv_setref_iv
6232 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6233 argument will be upgraded to an RV. That RV will be modified to point to
6234 the new SV. The C<classname> argument indicates the package for the
6235 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6236 will be returned and will have a reference count of 1.
6242 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6244 sv_setiv(newSVrv(rv,classname), iv);
6249 =for apidoc sv_setref_nv
6251 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6252 argument will be upgraded to an RV. That RV will be modified to point to
6253 the new SV. The C<classname> argument indicates the package for the
6254 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6255 will be returned and will have a reference count of 1.
6261 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6263 sv_setnv(newSVrv(rv,classname), nv);
6268 =for apidoc sv_setref_pvn
6270 Copies a string into a new SV, optionally blessing the SV. The length of the
6271 string must be specified with C<n>. The C<rv> argument will be upgraded to
6272 an RV. That RV will be modified to point to the new SV. The C<classname>
6273 argument indicates the package for the blessing. Set C<classname> to
6274 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6275 a reference count of 1.
6277 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6283 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6285 sv_setpvn(newSVrv(rv,classname), pv, n);
6290 =for apidoc sv_bless
6292 Blesses an SV into a specified package. The SV must be an RV. The package
6293 must be designated by its stash (see C<gv_stashpv()>). The reference count
6294 of the SV is unaffected.
6300 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6304 Perl_croak(aTHX_ "Can't bless non-reference value");
6306 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6307 if (SvREADONLY(tmpRef))
6308 Perl_croak(aTHX_ PL_no_modify);
6309 if (SvOBJECT(tmpRef)) {
6310 if (SvTYPE(tmpRef) != SVt_PVIO)
6312 SvREFCNT_dec(SvSTASH(tmpRef));
6315 SvOBJECT_on(tmpRef);
6316 if (SvTYPE(tmpRef) != SVt_PVIO)
6318 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6319 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6330 S_sv_unglob(pTHX_ SV *sv)
6334 assert(SvTYPE(sv) == SVt_PVGV);
6339 SvREFCNT_dec(GvSTASH(sv));
6340 GvSTASH(sv) = Nullhv;
6342 sv_unmagic(sv, '*');
6343 Safefree(GvNAME(sv));
6346 /* need to keep SvANY(sv) in the right arena */
6347 xpvmg = new_XPVMG();
6348 StructCopy(SvANY(sv), xpvmg, XPVMG);
6349 del_XPVGV(SvANY(sv));
6352 SvFLAGS(sv) &= ~SVTYPEMASK;
6353 SvFLAGS(sv) |= SVt_PVMG;
6357 =for apidoc sv_unref_flags
6359 Unsets the RV status of the SV, and decrements the reference count of
6360 whatever was being referenced by the RV. This can almost be thought of
6361 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6362 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6363 (otherwise the decrementing is conditional on the reference count being
6364 different from one or the reference being a readonly SV).
6371 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6375 if (SvWEAKREF(sv)) {
6383 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6385 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6386 sv_2mortal(rv); /* Schedule for freeing later */
6390 =for apidoc sv_unref
6392 Unsets the RV status of the SV, and decrements the reference count of
6393 whatever was being referenced by the RV. This can almost be thought of
6394 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6395 being zero. See C<SvROK_off>.
6401 Perl_sv_unref(pTHX_ SV *sv)
6403 sv_unref_flags(sv, 0);
6407 Perl_sv_taint(pTHX_ SV *sv)
6409 sv_magic((sv), Nullsv, 't', Nullch, 0);
6413 Perl_sv_untaint(pTHX_ SV *sv)
6415 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6416 MAGIC *mg = mg_find(sv, 't');
6423 Perl_sv_tainted(pTHX_ SV *sv)
6425 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6426 MAGIC *mg = mg_find(sv, 't');
6427 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6434 =for apidoc sv_setpviv
6436 Copies an integer into the given SV, also updating its string value.
6437 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6443 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6445 char buf[TYPE_CHARS(UV)];
6447 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6449 sv_setpvn(sv, ptr, ebuf - ptr);
6454 =for apidoc sv_setpviv_mg
6456 Like C<sv_setpviv>, but also handles 'set' magic.
6462 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6464 char buf[TYPE_CHARS(UV)];
6466 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6468 sv_setpvn(sv, ptr, ebuf - ptr);
6472 #if defined(PERL_IMPLICIT_CONTEXT)
6474 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6478 va_start(args, pat);
6479 sv_vsetpvf(sv, pat, &args);
6485 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6489 va_start(args, pat);
6490 sv_vsetpvf_mg(sv, pat, &args);
6496 =for apidoc sv_setpvf
6498 Processes its arguments like C<sprintf> and sets an SV to the formatted
6499 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6505 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6508 va_start(args, pat);
6509 sv_vsetpvf(sv, pat, &args);
6514 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6516 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6520 =for apidoc sv_setpvf_mg
6522 Like C<sv_setpvf>, but also handles 'set' magic.
6528 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6531 va_start(args, pat);
6532 sv_vsetpvf_mg(sv, pat, &args);
6537 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6539 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6543 #if defined(PERL_IMPLICIT_CONTEXT)
6545 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6549 va_start(args, pat);
6550 sv_vcatpvf(sv, pat, &args);
6555 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6559 va_start(args, pat);
6560 sv_vcatpvf_mg(sv, pat, &args);
6566 =for apidoc sv_catpvf
6568 Processes its arguments like C<sprintf> and appends the formatted output
6569 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6570 typically be called after calling this function to handle 'set' magic.
6576 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6579 va_start(args, pat);
6580 sv_vcatpvf(sv, pat, &args);
6585 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6587 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6591 =for apidoc sv_catpvf_mg
6593 Like C<sv_catpvf>, but also handles 'set' magic.
6599 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6602 va_start(args, pat);
6603 sv_vcatpvf_mg(sv, pat, &args);
6608 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6610 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6615 =for apidoc sv_vsetpvfn
6617 Works like C<vcatpvfn> but copies the text into the SV instead of
6624 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6626 sv_setpvn(sv, "", 0);
6627 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6631 =for apidoc sv_vcatpvfn
6633 Processes its arguments like C<vsprintf> and appends the formatted output
6634 to an SV. Uses an array of SVs if the C style variable argument list is
6635 missing (NULL). When running with taint checks enabled, indicates via
6636 C<maybe_tainted> if results are untrustworthy (often due to the use of
6643 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6650 static char nullstr[] = "(null)";
6653 /* no matter what, this is a string now */
6654 (void)SvPV_force(sv, origlen);
6656 /* special-case "", "%s", and "%_" */
6659 if (patlen == 2 && pat[0] == '%') {
6663 char *s = va_arg(*args, char*);
6664 sv_catpv(sv, s ? s : nullstr);
6666 else if (svix < svmax) {
6667 sv_catsv(sv, *svargs);
6668 if (DO_UTF8(*svargs))
6674 argsv = va_arg(*args, SV*);
6675 sv_catsv(sv, argsv);
6680 /* See comment on '_' below */
6685 patend = (char*)pat + patlen;
6686 for (p = (char*)pat; p < patend; p = q) {
6689 bool vectorize = FALSE;
6696 bool has_precis = FALSE;
6698 bool is_utf = FALSE;
6701 U8 utf8buf[UTF8_MAXLEN+1];
6702 STRLEN esignlen = 0;
6704 char *eptr = Nullch;
6706 /* Times 4: a decimal digit takes more than 3 binary digits.
6707 * NV_DIG: mantissa takes than many decimal digits.
6708 * Plus 32: Playing safe. */
6709 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6710 /* large enough for "%#.#f" --chip */
6711 /* what about long double NVs? --jhi */
6714 U8 *vecstr = Null(U8*);
6726 STRLEN dotstrlen = 1;
6727 I32 epix = 0; /* explicit parameter index */
6728 I32 ewix = 0; /* explicit width index */
6729 bool asterisk = FALSE;
6731 for (q = p; q < patend && *q != '%'; ++q) ;
6733 sv_catpvn(sv, p, q - p);
6762 case '*': /* printf("%*vX",":",$ipv6addr) */
6767 vecsv = va_arg(*args, SV*);
6768 else if (svix < svmax)
6769 vecsv = svargs[svix++];
6772 dotstr = SvPVx(vecsv,dotstrlen);
6800 case '1': case '2': case '3':
6801 case '4': case '5': case '6':
6802 case '7': case '8': case '9':
6805 width = width * 10 + (*q++ - '0');
6807 if (asterisk && ewix == 0) {
6812 } else if (epix == 0) {
6824 i = va_arg(*args, int);
6826 i = (ewix ? ewix <= svmax : svix < svmax) ?
6827 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6829 width = (i < 0) ? -i : i;
6838 i = va_arg(*args, int);
6840 i = (ewix ? ewix <= svmax : svix < svmax)
6841 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6842 precis = (i < 0) ? 0 : i;
6848 precis = precis * 10 + (*q++ - '0');
6855 vecsv = va_arg(*args, SV*);
6856 vecstr = (U8*)SvPVx(vecsv,veclen);
6857 utf = DO_UTF8(vecsv);
6859 else if (epix ? epix <= svmax : svix < svmax) {
6860 vecsv = svargs[epix ? epix-1 : svix++];
6861 vecstr = (U8*)SvPVx(vecsv,veclen);
6862 utf = DO_UTF8(vecsv);
6873 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6884 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6885 if (*(q + 1) == 'l') { /* lld, llf */
6912 uv = va_arg(*args, int);
6914 uv = (epix ? epix <= svmax : svix < svmax) ?
6915 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6916 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6917 eptr = (char*)utf8buf;
6918 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6930 eptr = va_arg(*args, char*);
6932 #ifdef MACOS_TRADITIONAL
6933 /* On MacOS, %#s format is used for Pascal strings */
6938 elen = strlen(eptr);
6941 elen = sizeof nullstr - 1;
6944 else if (epix ? epix <= svmax : svix < svmax) {
6945 argsv = svargs[epix ? epix-1 : svix++];
6946 eptr = SvPVx(argsv, elen);
6947 if (DO_UTF8(argsv)) {
6948 if (has_precis && precis < elen) {
6950 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6953 if (width) { /* fudge width (can't fudge elen) */
6954 width += elen - sv_len_utf8(argsv);
6963 * The "%_" hack might have to be changed someday,
6964 * if ISO or ANSI decide to use '_' for something.
6965 * So we keep it hidden from users' code.
6969 argsv = va_arg(*args,SV*);
6970 eptr = SvPVx(argsv, elen);
6976 if (has_precis && elen > precis)
6986 uv = PTR2UV(va_arg(*args, void*));
6988 uv = (epix ? epix <= svmax : svix < svmax) ?
6989 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
7009 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7019 case 'h': iv = (short)va_arg(*args, int); break;
7020 default: iv = va_arg(*args, int); break;
7021 case 'l': iv = va_arg(*args, long); break;
7022 case 'V': iv = va_arg(*args, IV); break;
7024 case 'q': iv = va_arg(*args, Quad_t); break;
7029 iv = (epix ? epix <= svmax : svix < svmax) ?
7030 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
7032 case 'h': iv = (short)iv; break;
7034 case 'l': iv = (long)iv; break;
7037 case 'q': iv = (Quad_t)iv; break;
7044 esignbuf[esignlen++] = plus;
7048 esignbuf[esignlen++] = '-';
7092 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7102 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7103 default: uv = va_arg(*args, unsigned); break;
7104 case 'l': uv = va_arg(*args, unsigned long); break;
7105 case 'V': uv = va_arg(*args, UV); break;
7107 case 'q': uv = va_arg(*args, Quad_t); break;
7112 uv = (epix ? epix <= svmax : svix < svmax) ?
7113 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
7115 case 'h': uv = (unsigned short)uv; break;
7117 case 'l': uv = (unsigned long)uv; break;
7120 case 'q': uv = (Quad_t)uv; break;
7126 eptr = ebuf + sizeof ebuf;
7132 p = (char*)((c == 'X')
7133 ? "0123456789ABCDEF" : "0123456789abcdef");
7139 esignbuf[esignlen++] = '0';
7140 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7146 *--eptr = '0' + dig;
7148 if (alt && *eptr != '0')
7154 *--eptr = '0' + dig;
7157 esignbuf[esignlen++] = '0';
7158 esignbuf[esignlen++] = 'b';
7161 default: /* it had better be ten or less */
7162 #if defined(PERL_Y2KWARN)
7163 if (ckWARN(WARN_Y2K)) {
7165 char *s = SvPV(sv,n);
7166 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7167 && (n == 2 || !isDIGIT(s[n-3])))
7169 Perl_warner(aTHX_ WARN_Y2K,
7170 "Possible Y2K bug: %%%c %s",
7171 c, "format string following '19'");
7177 *--eptr = '0' + dig;
7178 } while (uv /= base);
7181 elen = (ebuf + sizeof ebuf) - eptr;
7184 zeros = precis - elen;
7185 else if (precis == 0 && elen == 1 && *eptr == '0')
7190 /* FLOATING POINT */
7193 c = 'f'; /* maybe %F isn't supported here */
7199 /* This is evil, but floating point is even more evil */
7203 nv = va_arg(*args, NV);
7205 nv = (epix ? epix <= svmax : svix < svmax) ?
7206 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
7209 if (c != 'e' && c != 'E') {
7211 (void)Perl_frexp(nv, &i);
7212 if (i == PERL_INT_MIN)
7213 Perl_die(aTHX_ "panic: frexp");
7215 need = BIT_DIGITS(i);
7217 need += has_precis ? precis : 6; /* known default */
7221 need += 20; /* fudge factor */
7222 if (PL_efloatsize < need) {
7223 Safefree(PL_efloatbuf);
7224 PL_efloatsize = need + 20; /* more fudge */
7225 New(906, PL_efloatbuf, PL_efloatsize, char);
7226 PL_efloatbuf[0] = '\0';
7229 eptr = ebuf + sizeof ebuf;
7232 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7234 /* Copy the one or more characters in a long double
7235 * format before the 'base' ([efgEFG]) character to
7236 * the format string. */
7237 static char const prifldbl[] = PERL_PRIfldbl;
7238 char const *p = prifldbl + sizeof(prifldbl) - 3;
7239 while (p >= prifldbl) { *--eptr = *p--; }
7244 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7249 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7261 /* No taint. Otherwise we are in the strange situation
7262 * where printf() taints but print($float) doesn't.
7264 (void)sprintf(PL_efloatbuf, eptr, nv);
7266 eptr = PL_efloatbuf;
7267 elen = strlen(PL_efloatbuf);
7274 i = SvCUR(sv) - origlen;
7277 case 'h': *(va_arg(*args, short*)) = i; break;
7278 default: *(va_arg(*args, int*)) = i; break;
7279 case 'l': *(va_arg(*args, long*)) = i; break;
7280 case 'V': *(va_arg(*args, IV*)) = i; break;
7282 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7286 else if (epix ? epix <= svmax : svix < svmax)
7287 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
7288 continue; /* not "break" */
7295 if (!args && ckWARN(WARN_PRINTF) &&
7296 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7297 SV *msg = sv_newmortal();
7298 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7299 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7302 Perl_sv_catpvf(aTHX_ msg,
7303 "\"%%%c\"", c & 0xFF);
7305 Perl_sv_catpvf(aTHX_ msg,
7306 "\"%%\\%03"UVof"\"",
7309 sv_catpv(msg, "end of string");
7310 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7313 /* output mangled stuff ... */
7319 /* ... right here, because formatting flags should not apply */
7320 SvGROW(sv, SvCUR(sv) + elen + 1);
7322 memcpy(p, eptr, elen);
7325 SvCUR(sv) = p - SvPVX(sv);
7326 continue; /* not "break" */
7329 have = esignlen + zeros + elen;
7330 need = (have > width ? have : width);
7333 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7335 if (esignlen && fill == '0') {
7336 for (i = 0; i < esignlen; i++)
7340 memset(p, fill, gap);
7343 if (esignlen && fill != '0') {
7344 for (i = 0; i < esignlen; i++)
7348 for (i = zeros; i; i--)
7352 memcpy(p, eptr, elen);
7356 memset(p, ' ', gap);
7361 memcpy(p, dotstr, dotstrlen);
7365 vectorize = FALSE; /* done iterating over vecstr */
7370 SvCUR(sv) = p - SvPVX(sv);
7378 #if defined(USE_ITHREADS)
7380 #if defined(USE_THREADS)
7381 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7384 #ifndef GpREFCNT_inc
7385 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7389 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7390 #define av_dup(s) (AV*)sv_dup((SV*)s)
7391 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7392 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7393 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7394 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7395 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7396 #define io_dup(s) (IO*)sv_dup((SV*)s)
7397 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7398 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7399 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7400 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7401 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7404 Perl_re_dup(pTHX_ REGEXP *r)
7406 /* XXX fix when pmop->op_pmregexp becomes shared */
7407 return ReREFCNT_inc(r);
7411 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7415 return (PerlIO*)NULL;
7417 /* look for it in the table first */
7418 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7422 /* create anew and remember what it is */
7423 ret = PerlIO_fdupopen(aTHX_ fp);
7424 ptr_table_store(PL_ptr_table, fp, ret);
7429 Perl_dirp_dup(pTHX_ DIR *dp)
7438 Perl_gp_dup(pTHX_ GP *gp)
7443 /* look for it in the table first */
7444 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7448 /* create anew and remember what it is */
7449 Newz(0, ret, 1, GP);
7450 ptr_table_store(PL_ptr_table, gp, ret);
7453 ret->gp_refcnt = 0; /* must be before any other dups! */
7454 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7455 ret->gp_io = io_dup_inc(gp->gp_io);
7456 ret->gp_form = cv_dup_inc(gp->gp_form);
7457 ret->gp_av = av_dup_inc(gp->gp_av);
7458 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7459 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7460 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7461 ret->gp_cvgen = gp->gp_cvgen;
7462 ret->gp_flags = gp->gp_flags;
7463 ret->gp_line = gp->gp_line;
7464 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7469 Perl_mg_dup(pTHX_ MAGIC *mg)
7471 MAGIC *mgret = (MAGIC*)NULL;
7474 return (MAGIC*)NULL;
7475 /* look for it in the table first */
7476 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7480 for (; mg; mg = mg->mg_moremagic) {
7482 Newz(0, nmg, 1, MAGIC);
7486 mgprev->mg_moremagic = nmg;
7487 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7488 nmg->mg_private = mg->mg_private;
7489 nmg->mg_type = mg->mg_type;
7490 nmg->mg_flags = mg->mg_flags;
7491 if (mg->mg_type == 'r') {
7492 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7495 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7496 ? sv_dup_inc(mg->mg_obj)
7497 : sv_dup(mg->mg_obj);
7499 nmg->mg_len = mg->mg_len;
7500 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7501 if (mg->mg_ptr && mg->mg_type != 'g') {
7502 if (mg->mg_len >= 0) {
7503 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7504 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7505 AMT *amtp = (AMT*)mg->mg_ptr;
7506 AMT *namtp = (AMT*)nmg->mg_ptr;
7508 for (i = 1; i < NofAMmeth; i++) {
7509 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7513 else if (mg->mg_len == HEf_SVKEY)
7514 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7522 Perl_ptr_table_new(pTHX)
7525 Newz(0, tbl, 1, PTR_TBL_t);
7528 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7533 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7535 PTR_TBL_ENT_t *tblent;
7536 UV hash = PTR2UV(sv);
7538 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7539 for (; tblent; tblent = tblent->next) {
7540 if (tblent->oldval == sv)
7541 return tblent->newval;
7547 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7549 PTR_TBL_ENT_t *tblent, **otblent;
7550 /* XXX this may be pessimal on platforms where pointers aren't good
7551 * hash values e.g. if they grow faster in the most significant
7553 UV hash = PTR2UV(oldv);
7557 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7558 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7559 if (tblent->oldval == oldv) {
7560 tblent->newval = newv;
7565 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7566 tblent->oldval = oldv;
7567 tblent->newval = newv;
7568 tblent->next = *otblent;
7571 if (i && tbl->tbl_items > tbl->tbl_max)
7572 ptr_table_split(tbl);
7576 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7578 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7579 UV oldsize = tbl->tbl_max + 1;
7580 UV newsize = oldsize * 2;
7583 Renew(ary, newsize, PTR_TBL_ENT_t*);
7584 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7585 tbl->tbl_max = --newsize;
7587 for (i=0; i < oldsize; i++, ary++) {
7588 PTR_TBL_ENT_t **curentp, **entp, *ent;
7591 curentp = ary + oldsize;
7592 for (entp = ary, ent = *ary; ent; ent = *entp) {
7593 if ((newsize & PTR2UV(ent->oldval)) != i) {
7595 ent->next = *curentp;
7610 Perl_sv_dup(pTHX_ SV *sstr)
7614 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7616 /* look for it in the table first */
7617 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7621 /* create anew and remember what it is */
7623 ptr_table_store(PL_ptr_table, sstr, dstr);
7626 SvFLAGS(dstr) = SvFLAGS(sstr);
7627 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7628 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7631 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7632 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7633 PL_watch_pvx, SvPVX(sstr));
7636 switch (SvTYPE(sstr)) {
7641 SvANY(dstr) = new_XIV();
7642 SvIVX(dstr) = SvIVX(sstr);
7645 SvANY(dstr) = new_XNV();
7646 SvNVX(dstr) = SvNVX(sstr);
7649 SvANY(dstr) = new_XRV();
7650 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7653 SvANY(dstr) = new_XPV();
7654 SvCUR(dstr) = SvCUR(sstr);
7655 SvLEN(dstr) = SvLEN(sstr);
7657 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7658 else if (SvPVX(sstr) && SvLEN(sstr))
7659 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7661 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7664 SvANY(dstr) = new_XPVIV();
7665 SvCUR(dstr) = SvCUR(sstr);
7666 SvLEN(dstr) = SvLEN(sstr);
7667 SvIVX(dstr) = SvIVX(sstr);
7669 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7670 else if (SvPVX(sstr) && SvLEN(sstr))
7671 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7673 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7676 SvANY(dstr) = new_XPVNV();
7677 SvCUR(dstr) = SvCUR(sstr);
7678 SvLEN(dstr) = SvLEN(sstr);
7679 SvIVX(dstr) = SvIVX(sstr);
7680 SvNVX(dstr) = SvNVX(sstr);
7682 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7683 else if (SvPVX(sstr) && SvLEN(sstr))
7684 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7686 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7689 SvANY(dstr) = new_XPVMG();
7690 SvCUR(dstr) = SvCUR(sstr);
7691 SvLEN(dstr) = SvLEN(sstr);
7692 SvIVX(dstr) = SvIVX(sstr);
7693 SvNVX(dstr) = SvNVX(sstr);
7694 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7695 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7697 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7698 else if (SvPVX(sstr) && SvLEN(sstr))
7699 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7701 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7704 SvANY(dstr) = new_XPVBM();
7705 SvCUR(dstr) = SvCUR(sstr);
7706 SvLEN(dstr) = SvLEN(sstr);
7707 SvIVX(dstr) = SvIVX(sstr);
7708 SvNVX(dstr) = SvNVX(sstr);
7709 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7710 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7712 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7713 else if (SvPVX(sstr) && SvLEN(sstr))
7714 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7716 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7717 BmRARE(dstr) = BmRARE(sstr);
7718 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7719 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7722 SvANY(dstr) = new_XPVLV();
7723 SvCUR(dstr) = SvCUR(sstr);
7724 SvLEN(dstr) = SvLEN(sstr);
7725 SvIVX(dstr) = SvIVX(sstr);
7726 SvNVX(dstr) = SvNVX(sstr);
7727 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7728 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7730 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7731 else if (SvPVX(sstr) && SvLEN(sstr))
7732 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7734 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7735 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7736 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7737 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7738 LvTYPE(dstr) = LvTYPE(sstr);
7741 SvANY(dstr) = new_XPVGV();
7742 SvCUR(dstr) = SvCUR(sstr);
7743 SvLEN(dstr) = SvLEN(sstr);
7744 SvIVX(dstr) = SvIVX(sstr);
7745 SvNVX(dstr) = SvNVX(sstr);
7746 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7747 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7749 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7750 else if (SvPVX(sstr) && SvLEN(sstr))
7751 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7753 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7754 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7755 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7756 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7757 GvFLAGS(dstr) = GvFLAGS(sstr);
7758 GvGP(dstr) = gp_dup(GvGP(sstr));
7759 (void)GpREFCNT_inc(GvGP(dstr));
7762 SvANY(dstr) = new_XPVIO();
7763 SvCUR(dstr) = SvCUR(sstr);
7764 SvLEN(dstr) = SvLEN(sstr);
7765 SvIVX(dstr) = SvIVX(sstr);
7766 SvNVX(dstr) = SvNVX(sstr);
7767 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7768 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7770 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7771 else if (SvPVX(sstr) && SvLEN(sstr))
7772 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7774 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7775 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7776 if (IoOFP(sstr) == IoIFP(sstr))
7777 IoOFP(dstr) = IoIFP(dstr);
7779 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7780 /* PL_rsfp_filters entries have fake IoDIRP() */
7781 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7782 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7784 IoDIRP(dstr) = IoDIRP(sstr);
7785 IoLINES(dstr) = IoLINES(sstr);
7786 IoPAGE(dstr) = IoPAGE(sstr);
7787 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7788 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7789 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7790 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7791 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7792 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7793 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7794 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7795 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7796 IoTYPE(dstr) = IoTYPE(sstr);
7797 IoFLAGS(dstr) = IoFLAGS(sstr);
7800 SvANY(dstr) = new_XPVAV();
7801 SvCUR(dstr) = SvCUR(sstr);
7802 SvLEN(dstr) = SvLEN(sstr);
7803 SvIVX(dstr) = SvIVX(sstr);
7804 SvNVX(dstr) = SvNVX(sstr);
7805 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7806 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7807 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7808 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7809 if (AvARRAY((AV*)sstr)) {
7810 SV **dst_ary, **src_ary;
7811 SSize_t items = AvFILLp((AV*)sstr) + 1;
7813 src_ary = AvARRAY((AV*)sstr);
7814 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7815 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7816 SvPVX(dstr) = (char*)dst_ary;
7817 AvALLOC((AV*)dstr) = dst_ary;
7818 if (AvREAL((AV*)sstr)) {
7820 *dst_ary++ = sv_dup_inc(*src_ary++);
7824 *dst_ary++ = sv_dup(*src_ary++);
7826 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7827 while (items-- > 0) {
7828 *dst_ary++ = &PL_sv_undef;
7832 SvPVX(dstr) = Nullch;
7833 AvALLOC((AV*)dstr) = (SV**)NULL;
7837 SvANY(dstr) = new_XPVHV();
7838 SvCUR(dstr) = SvCUR(sstr);
7839 SvLEN(dstr) = SvLEN(sstr);
7840 SvIVX(dstr) = SvIVX(sstr);
7841 SvNVX(dstr) = SvNVX(sstr);
7842 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7843 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7844 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7845 if (HvARRAY((HV*)sstr)) {
7847 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7848 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7849 Newz(0, dxhv->xhv_array,
7850 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7851 while (i <= sxhv->xhv_max) {
7852 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7853 !!HvSHAREKEYS(sstr));
7856 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7859 SvPVX(dstr) = Nullch;
7860 HvEITER((HV*)dstr) = (HE*)NULL;
7862 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7863 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7866 SvANY(dstr) = new_XPVFM();
7867 FmLINES(dstr) = FmLINES(sstr);
7871 SvANY(dstr) = new_XPVCV();
7873 SvCUR(dstr) = SvCUR(sstr);
7874 SvLEN(dstr) = SvLEN(sstr);
7875 SvIVX(dstr) = SvIVX(sstr);
7876 SvNVX(dstr) = SvNVX(sstr);
7877 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7878 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7879 if (SvPVX(sstr) && SvLEN(sstr))
7880 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7882 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7883 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7884 CvSTART(dstr) = CvSTART(sstr);
7885 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7886 CvXSUB(dstr) = CvXSUB(sstr);
7887 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7888 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7889 CvDEPTH(dstr) = CvDEPTH(sstr);
7890 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7891 /* XXX padlists are real, but pretend to be not */
7892 AvREAL_on(CvPADLIST(sstr));
7893 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7894 AvREAL_off(CvPADLIST(sstr));
7895 AvREAL_off(CvPADLIST(dstr));
7898 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7899 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7900 CvFLAGS(dstr) = CvFLAGS(sstr);
7903 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7907 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7914 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7919 return (PERL_CONTEXT*)NULL;
7921 /* look for it in the table first */
7922 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7926 /* create anew and remember what it is */
7927 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7928 ptr_table_store(PL_ptr_table, cxs, ncxs);
7931 PERL_CONTEXT *cx = &cxs[ix];
7932 PERL_CONTEXT *ncx = &ncxs[ix];
7933 ncx->cx_type = cx->cx_type;
7934 if (CxTYPE(cx) == CXt_SUBST) {
7935 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7938 ncx->blk_oldsp = cx->blk_oldsp;
7939 ncx->blk_oldcop = cx->blk_oldcop;
7940 ncx->blk_oldretsp = cx->blk_oldretsp;
7941 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7942 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7943 ncx->blk_oldpm = cx->blk_oldpm;
7944 ncx->blk_gimme = cx->blk_gimme;
7945 switch (CxTYPE(cx)) {
7947 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7948 ? cv_dup_inc(cx->blk_sub.cv)
7949 : cv_dup(cx->blk_sub.cv));
7950 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7951 ? av_dup_inc(cx->blk_sub.argarray)
7953 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7954 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7955 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7956 ncx->blk_sub.lval = cx->blk_sub.lval;
7959 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7960 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7961 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7962 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7963 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7966 ncx->blk_loop.label = cx->blk_loop.label;
7967 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7968 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7969 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7970 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7971 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7972 ? cx->blk_loop.iterdata
7973 : gv_dup((GV*)cx->blk_loop.iterdata));
7974 ncx->blk_loop.oldcurpad
7975 = (SV**)ptr_table_fetch(PL_ptr_table,
7976 cx->blk_loop.oldcurpad);
7977 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7978 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7979 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7980 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7981 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7984 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7985 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7986 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7987 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8000 Perl_si_dup(pTHX_ PERL_SI *si)
8005 return (PERL_SI*)NULL;
8007 /* look for it in the table first */
8008 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8012 /* create anew and remember what it is */
8013 Newz(56, nsi, 1, PERL_SI);
8014 ptr_table_store(PL_ptr_table, si, nsi);
8016 nsi->si_stack = av_dup_inc(si->si_stack);
8017 nsi->si_cxix = si->si_cxix;
8018 nsi->si_cxmax = si->si_cxmax;
8019 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8020 nsi->si_type = si->si_type;
8021 nsi->si_prev = si_dup(si->si_prev);
8022 nsi->si_next = si_dup(si->si_next);
8023 nsi->si_markoff = si->si_markoff;
8028 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8029 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8030 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8031 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8032 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8033 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8034 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8035 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8036 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8037 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8038 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8039 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8042 #define pv_dup_inc(p) SAVEPV(p)
8043 #define pv_dup(p) SAVEPV(p)
8044 #define svp_dup_inc(p,pp) any_dup(p,pp)
8047 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8054 /* look for it in the table first */
8055 ret = ptr_table_fetch(PL_ptr_table, v);
8059 /* see if it is part of the interpreter structure */
8060 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8061 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8069 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8071 ANY *ss = proto_perl->Tsavestack;
8072 I32 ix = proto_perl->Tsavestack_ix;
8073 I32 max = proto_perl->Tsavestack_max;
8086 void (*dptr) (void*);
8087 void (*dxptr) (pTHXo_ void*);
8090 Newz(54, nss, max, ANY);
8096 case SAVEt_ITEM: /* normal string */
8097 sv = (SV*)POPPTR(ss,ix);
8098 TOPPTR(nss,ix) = sv_dup_inc(sv);
8099 sv = (SV*)POPPTR(ss,ix);
8100 TOPPTR(nss,ix) = sv_dup_inc(sv);
8102 case SAVEt_SV: /* scalar reference */
8103 sv = (SV*)POPPTR(ss,ix);
8104 TOPPTR(nss,ix) = sv_dup_inc(sv);
8105 gv = (GV*)POPPTR(ss,ix);
8106 TOPPTR(nss,ix) = gv_dup_inc(gv);
8108 case SAVEt_GENERIC_PVREF: /* generic char* */
8109 c = (char*)POPPTR(ss,ix);
8110 TOPPTR(nss,ix) = pv_dup(c);
8111 ptr = POPPTR(ss,ix);
8112 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8114 case SAVEt_GENERIC_SVREF: /* generic sv */
8115 case SAVEt_SVREF: /* scalar reference */
8116 sv = (SV*)POPPTR(ss,ix);
8117 TOPPTR(nss,ix) = sv_dup_inc(sv);
8118 ptr = POPPTR(ss,ix);
8119 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8121 case SAVEt_AV: /* array reference */
8122 av = (AV*)POPPTR(ss,ix);
8123 TOPPTR(nss,ix) = av_dup_inc(av);
8124 gv = (GV*)POPPTR(ss,ix);
8125 TOPPTR(nss,ix) = gv_dup(gv);
8127 case SAVEt_HV: /* hash reference */
8128 hv = (HV*)POPPTR(ss,ix);
8129 TOPPTR(nss,ix) = hv_dup_inc(hv);
8130 gv = (GV*)POPPTR(ss,ix);
8131 TOPPTR(nss,ix) = gv_dup(gv);
8133 case SAVEt_INT: /* int reference */
8134 ptr = POPPTR(ss,ix);
8135 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8136 intval = (int)POPINT(ss,ix);
8137 TOPINT(nss,ix) = intval;
8139 case SAVEt_LONG: /* long reference */
8140 ptr = POPPTR(ss,ix);
8141 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8142 longval = (long)POPLONG(ss,ix);
8143 TOPLONG(nss,ix) = longval;
8145 case SAVEt_I32: /* I32 reference */
8146 case SAVEt_I16: /* I16 reference */
8147 case SAVEt_I8: /* I8 reference */
8148 ptr = POPPTR(ss,ix);
8149 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8153 case SAVEt_IV: /* IV reference */
8154 ptr = POPPTR(ss,ix);
8155 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8159 case SAVEt_SPTR: /* SV* reference */
8160 ptr = POPPTR(ss,ix);
8161 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8162 sv = (SV*)POPPTR(ss,ix);
8163 TOPPTR(nss,ix) = sv_dup(sv);
8165 case SAVEt_VPTR: /* random* reference */
8166 ptr = POPPTR(ss,ix);
8167 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8168 ptr = POPPTR(ss,ix);
8169 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8171 case SAVEt_PPTR: /* char* reference */
8172 ptr = POPPTR(ss,ix);
8173 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8174 c = (char*)POPPTR(ss,ix);
8175 TOPPTR(nss,ix) = pv_dup(c);
8177 case SAVEt_HPTR: /* HV* reference */
8178 ptr = POPPTR(ss,ix);
8179 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8180 hv = (HV*)POPPTR(ss,ix);
8181 TOPPTR(nss,ix) = hv_dup(hv);
8183 case SAVEt_APTR: /* AV* reference */
8184 ptr = POPPTR(ss,ix);
8185 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8186 av = (AV*)POPPTR(ss,ix);
8187 TOPPTR(nss,ix) = av_dup(av);
8190 gv = (GV*)POPPTR(ss,ix);
8191 TOPPTR(nss,ix) = gv_dup(gv);
8193 case SAVEt_GP: /* scalar reference */
8194 gp = (GP*)POPPTR(ss,ix);
8195 TOPPTR(nss,ix) = gp = gp_dup(gp);
8196 (void)GpREFCNT_inc(gp);
8197 gv = (GV*)POPPTR(ss,ix);
8198 TOPPTR(nss,ix) = gv_dup_inc(c);
8199 c = (char*)POPPTR(ss,ix);
8200 TOPPTR(nss,ix) = pv_dup(c);
8207 sv = (SV*)POPPTR(ss,ix);
8208 TOPPTR(nss,ix) = sv_dup_inc(sv);
8211 ptr = POPPTR(ss,ix);
8212 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8213 /* these are assumed to be refcounted properly */
8214 switch (((OP*)ptr)->op_type) {
8221 TOPPTR(nss,ix) = ptr;
8226 TOPPTR(nss,ix) = Nullop;
8231 TOPPTR(nss,ix) = Nullop;
8234 c = (char*)POPPTR(ss,ix);
8235 TOPPTR(nss,ix) = pv_dup_inc(c);
8238 longval = POPLONG(ss,ix);
8239 TOPLONG(nss,ix) = longval;
8242 hv = (HV*)POPPTR(ss,ix);
8243 TOPPTR(nss,ix) = hv_dup_inc(hv);
8244 c = (char*)POPPTR(ss,ix);
8245 TOPPTR(nss,ix) = pv_dup_inc(c);
8249 case SAVEt_DESTRUCTOR:
8250 ptr = POPPTR(ss,ix);
8251 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8252 dptr = POPDPTR(ss,ix);
8253 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8255 case SAVEt_DESTRUCTOR_X:
8256 ptr = POPPTR(ss,ix);
8257 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8258 dxptr = POPDXPTR(ss,ix);
8259 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8261 case SAVEt_REGCONTEXT:
8267 case SAVEt_STACK_POS: /* Position on Perl stack */
8271 case SAVEt_AELEM: /* array element */
8272 sv = (SV*)POPPTR(ss,ix);
8273 TOPPTR(nss,ix) = sv_dup_inc(sv);
8276 av = (AV*)POPPTR(ss,ix);
8277 TOPPTR(nss,ix) = av_dup_inc(av);
8279 case SAVEt_HELEM: /* hash element */
8280 sv = (SV*)POPPTR(ss,ix);
8281 TOPPTR(nss,ix) = sv_dup_inc(sv);
8282 sv = (SV*)POPPTR(ss,ix);
8283 TOPPTR(nss,ix) = sv_dup_inc(sv);
8284 hv = (HV*)POPPTR(ss,ix);
8285 TOPPTR(nss,ix) = hv_dup_inc(hv);
8288 ptr = POPPTR(ss,ix);
8289 TOPPTR(nss,ix) = ptr;
8296 av = (AV*)POPPTR(ss,ix);
8297 TOPPTR(nss,ix) = av_dup(av);
8300 longval = (long)POPLONG(ss,ix);
8301 TOPLONG(nss,ix) = longval;
8302 ptr = POPPTR(ss,ix);
8303 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8304 sv = (SV*)POPPTR(ss,ix);
8305 TOPPTR(nss,ix) = sv_dup(sv);
8308 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8320 perl_clone(PerlInterpreter *proto_perl, UV flags)
8323 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8326 #ifdef PERL_IMPLICIT_SYS
8327 return perl_clone_using(proto_perl, flags,
8329 proto_perl->IMemShared,
8330 proto_perl->IMemParse,
8340 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8341 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8342 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8343 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8344 struct IPerlDir* ipD, struct IPerlSock* ipS,
8345 struct IPerlProc* ipP)
8347 /* XXX many of the string copies here can be optimized if they're
8348 * constants; they need to be allocated as common memory and just
8349 * their pointers copied. */
8353 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8355 PERL_SET_THX(pPerl);
8356 # else /* !PERL_OBJECT */
8357 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8358 PERL_SET_THX(my_perl);
8361 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8366 # else /* !DEBUGGING */
8367 Zero(my_perl, 1, PerlInterpreter);
8368 # endif /* DEBUGGING */
8372 PL_MemShared = ipMS;
8380 # endif /* PERL_OBJECT */
8381 #else /* !PERL_IMPLICIT_SYS */
8383 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8384 PERL_SET_THX(my_perl);
8387 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8392 # else /* !DEBUGGING */
8393 Zero(my_perl, 1, PerlInterpreter);
8394 # endif /* DEBUGGING */
8395 #endif /* PERL_IMPLICIT_SYS */
8398 PL_xiv_arenaroot = NULL;
8400 PL_xnv_arenaroot = NULL;
8402 PL_xrv_arenaroot = NULL;
8404 PL_xpv_arenaroot = NULL;
8406 PL_xpviv_arenaroot = NULL;
8407 PL_xpviv_root = NULL;
8408 PL_xpvnv_arenaroot = NULL;
8409 PL_xpvnv_root = NULL;
8410 PL_xpvcv_arenaroot = NULL;
8411 PL_xpvcv_root = NULL;
8412 PL_xpvav_arenaroot = NULL;
8413 PL_xpvav_root = NULL;
8414 PL_xpvhv_arenaroot = NULL;
8415 PL_xpvhv_root = NULL;
8416 PL_xpvmg_arenaroot = NULL;
8417 PL_xpvmg_root = NULL;
8418 PL_xpvlv_arenaroot = NULL;
8419 PL_xpvlv_root = NULL;
8420 PL_xpvbm_arenaroot = NULL;
8421 PL_xpvbm_root = NULL;
8422 PL_he_arenaroot = NULL;
8424 PL_nice_chunk = NULL;
8425 PL_nice_chunk_size = 0;
8428 PL_sv_root = Nullsv;
8429 PL_sv_arenaroot = Nullsv;
8431 PL_debug = proto_perl->Idebug;
8433 /* create SV map for pointer relocation */
8434 PL_ptr_table = ptr_table_new();
8436 /* initialize these special pointers as early as possible */
8437 SvANY(&PL_sv_undef) = NULL;
8438 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8439 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8440 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8443 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8445 SvANY(&PL_sv_no) = new_XPVNV();
8447 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8448 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8449 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8450 SvCUR(&PL_sv_no) = 0;
8451 SvLEN(&PL_sv_no) = 1;
8452 SvNVX(&PL_sv_no) = 0;
8453 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8456 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8458 SvANY(&PL_sv_yes) = new_XPVNV();
8460 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8461 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8462 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8463 SvCUR(&PL_sv_yes) = 1;
8464 SvLEN(&PL_sv_yes) = 2;
8465 SvNVX(&PL_sv_yes) = 1;
8466 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8468 /* create shared string table */
8469 PL_strtab = newHV();
8470 HvSHAREKEYS_off(PL_strtab);
8471 hv_ksplit(PL_strtab, 512);
8472 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8474 PL_compiling = proto_perl->Icompiling;
8475 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8476 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8477 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8478 if (!specialWARN(PL_compiling.cop_warnings))
8479 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8480 if (!specialCopIO(PL_compiling.cop_io))
8481 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8482 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8484 /* pseudo environmental stuff */
8485 PL_origargc = proto_perl->Iorigargc;
8487 New(0, PL_origargv, i+1, char*);
8488 PL_origargv[i] = '\0';
8490 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8492 PL_envgv = gv_dup(proto_perl->Ienvgv);
8493 PL_incgv = gv_dup(proto_perl->Iincgv);
8494 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8495 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8496 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8497 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8500 PL_minus_c = proto_perl->Iminus_c;
8501 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8502 PL_localpatches = proto_perl->Ilocalpatches;
8503 PL_splitstr = proto_perl->Isplitstr;
8504 PL_preprocess = proto_perl->Ipreprocess;
8505 PL_minus_n = proto_perl->Iminus_n;
8506 PL_minus_p = proto_perl->Iminus_p;
8507 PL_minus_l = proto_perl->Iminus_l;
8508 PL_minus_a = proto_perl->Iminus_a;
8509 PL_minus_F = proto_perl->Iminus_F;
8510 PL_doswitches = proto_perl->Idoswitches;
8511 PL_dowarn = proto_perl->Idowarn;
8512 PL_doextract = proto_perl->Idoextract;
8513 PL_sawampersand = proto_perl->Isawampersand;
8514 PL_unsafe = proto_perl->Iunsafe;
8515 PL_inplace = SAVEPV(proto_perl->Iinplace);
8516 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8517 PL_perldb = proto_perl->Iperldb;
8518 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8520 /* magical thingies */
8521 /* XXX time(&PL_basetime) when asked for? */
8522 PL_basetime = proto_perl->Ibasetime;
8523 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8525 PL_maxsysfd = proto_perl->Imaxsysfd;
8526 PL_multiline = proto_perl->Imultiline;
8527 PL_statusvalue = proto_perl->Istatusvalue;
8529 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8532 /* shortcuts to various I/O objects */
8533 PL_stdingv = gv_dup(proto_perl->Istdingv);
8534 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8535 PL_defgv = gv_dup(proto_perl->Idefgv);
8536 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8537 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8538 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8540 /* shortcuts to regexp stuff */
8541 PL_replgv = gv_dup(proto_perl->Ireplgv);
8543 /* shortcuts to misc objects */
8544 PL_errgv = gv_dup(proto_perl->Ierrgv);
8546 /* shortcuts to debugging objects */
8547 PL_DBgv = gv_dup(proto_perl->IDBgv);
8548 PL_DBline = gv_dup(proto_perl->IDBline);
8549 PL_DBsub = gv_dup(proto_perl->IDBsub);
8550 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8551 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8552 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8553 PL_lineary = av_dup(proto_perl->Ilineary);
8554 PL_dbargs = av_dup(proto_perl->Idbargs);
8557 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8558 PL_curstash = hv_dup(proto_perl->Tcurstash);
8559 PL_debstash = hv_dup(proto_perl->Idebstash);
8560 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8561 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8563 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8564 PL_endav = av_dup_inc(proto_perl->Iendav);
8565 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8566 PL_initav = av_dup_inc(proto_perl->Iinitav);
8568 PL_sub_generation = proto_perl->Isub_generation;
8570 /* funky return mechanisms */
8571 PL_forkprocess = proto_perl->Iforkprocess;
8573 /* subprocess state */
8574 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8576 /* internal state */
8577 PL_tainting = proto_perl->Itainting;
8578 PL_maxo = proto_perl->Imaxo;
8579 if (proto_perl->Iop_mask)
8580 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8582 PL_op_mask = Nullch;
8584 /* current interpreter roots */
8585 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8586 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8587 PL_main_start = proto_perl->Imain_start;
8588 PL_eval_root = proto_perl->Ieval_root;
8589 PL_eval_start = proto_perl->Ieval_start;
8591 /* runtime control stuff */
8592 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8593 PL_copline = proto_perl->Icopline;
8595 PL_filemode = proto_perl->Ifilemode;
8596 PL_lastfd = proto_perl->Ilastfd;
8597 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8600 PL_gensym = proto_perl->Igensym;
8601 PL_preambled = proto_perl->Ipreambled;
8602 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8603 PL_laststatval = proto_perl->Ilaststatval;
8604 PL_laststype = proto_perl->Ilaststype;
8605 PL_mess_sv = Nullsv;
8607 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8608 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8610 /* interpreter atexit processing */
8611 PL_exitlistlen = proto_perl->Iexitlistlen;
8612 if (PL_exitlistlen) {
8613 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8614 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8617 PL_exitlist = (PerlExitListEntry*)NULL;
8618 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8620 PL_profiledata = NULL;
8621 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8622 /* PL_rsfp_filters entries have fake IoDIRP() */
8623 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8625 PL_compcv = cv_dup(proto_perl->Icompcv);
8626 PL_comppad = av_dup(proto_perl->Icomppad);
8627 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8628 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8629 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8630 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8631 proto_perl->Tcurpad);
8633 #ifdef HAVE_INTERP_INTERN
8634 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8637 /* more statics moved here */
8638 PL_generation = proto_perl->Igeneration;
8639 PL_DBcv = cv_dup(proto_perl->IDBcv);
8641 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8642 PL_in_clean_all = proto_perl->Iin_clean_all;
8644 PL_uid = proto_perl->Iuid;
8645 PL_euid = proto_perl->Ieuid;
8646 PL_gid = proto_perl->Igid;
8647 PL_egid = proto_perl->Iegid;
8648 PL_nomemok = proto_perl->Inomemok;
8649 PL_an = proto_perl->Ian;
8650 PL_cop_seqmax = proto_perl->Icop_seqmax;
8651 PL_op_seqmax = proto_perl->Iop_seqmax;
8652 PL_evalseq = proto_perl->Ievalseq;
8653 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8654 PL_origalen = proto_perl->Iorigalen;
8655 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8656 PL_osname = SAVEPV(proto_perl->Iosname);
8657 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8658 PL_sighandlerp = proto_perl->Isighandlerp;
8661 PL_runops = proto_perl->Irunops;
8663 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8666 PL_cshlen = proto_perl->Icshlen;
8667 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8670 PL_lex_state = proto_perl->Ilex_state;
8671 PL_lex_defer = proto_perl->Ilex_defer;
8672 PL_lex_expect = proto_perl->Ilex_expect;
8673 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8674 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8675 PL_lex_starts = proto_perl->Ilex_starts;
8676 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8677 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8678 PL_lex_op = proto_perl->Ilex_op;
8679 PL_lex_inpat = proto_perl->Ilex_inpat;
8680 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8681 PL_lex_brackets = proto_perl->Ilex_brackets;
8682 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8683 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8684 PL_lex_casemods = proto_perl->Ilex_casemods;
8685 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8686 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8688 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8689 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8690 PL_nexttoke = proto_perl->Inexttoke;
8692 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8693 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8694 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8695 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8696 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8697 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8698 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8699 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8700 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8701 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8702 PL_pending_ident = proto_perl->Ipending_ident;
8703 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8705 PL_expect = proto_perl->Iexpect;
8707 PL_multi_start = proto_perl->Imulti_start;
8708 PL_multi_end = proto_perl->Imulti_end;
8709 PL_multi_open = proto_perl->Imulti_open;
8710 PL_multi_close = proto_perl->Imulti_close;
8712 PL_error_count = proto_perl->Ierror_count;
8713 PL_subline = proto_perl->Isubline;
8714 PL_subname = sv_dup_inc(proto_perl->Isubname);
8716 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8717 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8718 PL_padix = proto_perl->Ipadix;
8719 PL_padix_floor = proto_perl->Ipadix_floor;
8720 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8722 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8723 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8724 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8725 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8726 PL_last_lop_op = proto_perl->Ilast_lop_op;
8727 PL_in_my = proto_perl->Iin_my;
8728 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8730 PL_cryptseen = proto_perl->Icryptseen;
8733 PL_hints = proto_perl->Ihints;
8735 PL_amagic_generation = proto_perl->Iamagic_generation;
8737 #ifdef USE_LOCALE_COLLATE
8738 PL_collation_ix = proto_perl->Icollation_ix;
8739 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8740 PL_collation_standard = proto_perl->Icollation_standard;
8741 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8742 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8743 #endif /* USE_LOCALE_COLLATE */
8745 #ifdef USE_LOCALE_NUMERIC
8746 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8747 PL_numeric_standard = proto_perl->Inumeric_standard;
8748 PL_numeric_local = proto_perl->Inumeric_local;
8749 PL_numeric_radix = proto_perl->Inumeric_radix;
8750 #endif /* !USE_LOCALE_NUMERIC */
8752 /* utf8 character classes */
8753 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8754 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8755 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8756 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8757 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8758 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8759 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8760 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8761 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8762 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8763 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8764 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8765 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8766 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8767 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8768 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8769 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8772 PL_last_swash_hv = Nullhv; /* reinits on demand */
8773 PL_last_swash_klen = 0;
8774 PL_last_swash_key[0]= '\0';
8775 PL_last_swash_tmps = (U8*)NULL;
8776 PL_last_swash_slen = 0;
8778 /* perly.c globals */
8779 PL_yydebug = proto_perl->Iyydebug;
8780 PL_yynerrs = proto_perl->Iyynerrs;
8781 PL_yyerrflag = proto_perl->Iyyerrflag;
8782 PL_yychar = proto_perl->Iyychar;
8783 PL_yyval = proto_perl->Iyyval;
8784 PL_yylval = proto_perl->Iyylval;
8786 PL_glob_index = proto_perl->Iglob_index;
8787 PL_srand_called = proto_perl->Isrand_called;
8788 PL_uudmap['M'] = 0; /* reinits on demand */
8789 PL_bitcount = Nullch; /* reinits on demand */
8791 if (proto_perl->Ipsig_ptr) {
8792 int sig_num[] = { SIG_NUM };
8793 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8794 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8795 for (i = 1; PL_sig_name[i]; i++) {
8796 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8797 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8801 PL_psig_ptr = (SV**)NULL;
8802 PL_psig_name = (SV**)NULL;
8805 /* thrdvar.h stuff */
8808 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8809 PL_tmps_ix = proto_perl->Ttmps_ix;
8810 PL_tmps_max = proto_perl->Ttmps_max;
8811 PL_tmps_floor = proto_perl->Ttmps_floor;
8812 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8814 while (i <= PL_tmps_ix) {
8815 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8819 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8820 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8821 Newz(54, PL_markstack, i, I32);
8822 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8823 - proto_perl->Tmarkstack);
8824 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8825 - proto_perl->Tmarkstack);
8826 Copy(proto_perl->Tmarkstack, PL_markstack,
8827 PL_markstack_ptr - PL_markstack + 1, I32);
8829 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8830 * NOTE: unlike the others! */
8831 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8832 PL_scopestack_max = proto_perl->Tscopestack_max;
8833 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8834 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8836 /* next push_return() sets PL_retstack[PL_retstack_ix]
8837 * NOTE: unlike the others! */
8838 PL_retstack_ix = proto_perl->Tretstack_ix;
8839 PL_retstack_max = proto_perl->Tretstack_max;
8840 Newz(54, PL_retstack, PL_retstack_max, OP*);
8841 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8843 /* NOTE: si_dup() looks at PL_markstack */
8844 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8846 /* PL_curstack = PL_curstackinfo->si_stack; */
8847 PL_curstack = av_dup(proto_perl->Tcurstack);
8848 PL_mainstack = av_dup(proto_perl->Tmainstack);
8850 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8851 PL_stack_base = AvARRAY(PL_curstack);
8852 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8853 - proto_perl->Tstack_base);
8854 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8856 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8857 * NOTE: unlike the others! */
8858 PL_savestack_ix = proto_perl->Tsavestack_ix;
8859 PL_savestack_max = proto_perl->Tsavestack_max;
8860 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8861 PL_savestack = ss_dup(proto_perl);
8865 ENTER; /* perl_destruct() wants to LEAVE; */
8868 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8869 PL_top_env = &PL_start_env;
8871 PL_op = proto_perl->Top;
8874 PL_Xpv = (XPV*)NULL;
8875 PL_na = proto_perl->Tna;
8877 PL_statbuf = proto_perl->Tstatbuf;
8878 PL_statcache = proto_perl->Tstatcache;
8879 PL_statgv = gv_dup(proto_perl->Tstatgv);
8880 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8882 PL_timesbuf = proto_perl->Ttimesbuf;
8885 PL_tainted = proto_perl->Ttainted;
8886 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8887 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8888 PL_rs = sv_dup_inc(proto_perl->Trs);
8889 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8890 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
8891 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8892 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8893 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8894 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8895 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8897 PL_restartop = proto_perl->Trestartop;
8898 PL_in_eval = proto_perl->Tin_eval;
8899 PL_delaymagic = proto_perl->Tdelaymagic;
8900 PL_dirty = proto_perl->Tdirty;
8901 PL_localizing = proto_perl->Tlocalizing;
8903 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8904 PL_protect = proto_perl->Tprotect;
8906 PL_errors = sv_dup_inc(proto_perl->Terrors);
8907 PL_av_fetch_sv = Nullsv;
8908 PL_hv_fetch_sv = Nullsv;
8909 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8910 PL_modcount = proto_perl->Tmodcount;
8911 PL_lastgotoprobe = Nullop;
8912 PL_dumpindent = proto_perl->Tdumpindent;
8914 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8915 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8916 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8917 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8918 PL_sortcxix = proto_perl->Tsortcxix;
8919 PL_efloatbuf = Nullch; /* reinits on demand */
8920 PL_efloatsize = 0; /* reinits on demand */
8924 PL_screamfirst = NULL;
8925 PL_screamnext = NULL;
8926 PL_maxscream = -1; /* reinits on demand */
8927 PL_lastscream = Nullsv;
8929 PL_watchaddr = NULL;
8930 PL_watchok = Nullch;
8932 PL_regdummy = proto_perl->Tregdummy;
8933 PL_regcomp_parse = Nullch;
8934 PL_regxend = Nullch;
8935 PL_regcode = (regnode*)NULL;
8938 PL_regprecomp = Nullch;
8943 PL_seen_zerolen = 0;
8945 PL_regcomp_rx = (regexp*)NULL;
8947 PL_colorset = 0; /* reinits PL_colors[] */
8948 /*PL_colors[6] = {0,0,0,0,0,0};*/
8949 PL_reg_whilem_seen = 0;
8950 PL_reginput = Nullch;
8953 PL_regstartp = (I32*)NULL;
8954 PL_regendp = (I32*)NULL;
8955 PL_reglastparen = (U32*)NULL;
8956 PL_regtill = Nullch;
8958 PL_reg_start_tmp = (char**)NULL;
8959 PL_reg_start_tmpl = 0;
8960 PL_regdata = (struct reg_data*)NULL;
8963 PL_reg_eval_set = 0;
8965 PL_regprogram = (regnode*)NULL;
8967 PL_regcc = (CURCUR*)NULL;
8968 PL_reg_call_cc = (struct re_cc_state*)NULL;
8969 PL_reg_re = (regexp*)NULL;
8970 PL_reg_ganch = Nullch;
8972 PL_reg_magic = (MAGIC*)NULL;
8974 PL_reg_oldcurpm = (PMOP*)NULL;
8975 PL_reg_curpm = (PMOP*)NULL;
8976 PL_reg_oldsaved = Nullch;
8977 PL_reg_oldsavedlen = 0;
8979 PL_reg_leftiter = 0;
8980 PL_reg_poscache = Nullch;
8981 PL_reg_poscache_size= 0;
8983 /* RE engine - function pointers */
8984 PL_regcompp = proto_perl->Tregcompp;
8985 PL_regexecp = proto_perl->Tregexecp;
8986 PL_regint_start = proto_perl->Tregint_start;
8987 PL_regint_string = proto_perl->Tregint_string;
8988 PL_regfree = proto_perl->Tregfree;
8990 PL_reginterp_cnt = 0;
8991 PL_reg_starttry = 0;
8994 return (PerlInterpreter*)pPerl;
9000 #else /* !USE_ITHREADS */
9006 #endif /* USE_ITHREADS */
9009 do_report_used(pTHXo_ SV *sv)
9011 if (SvTYPE(sv) != SVTYPEMASK) {
9012 PerlIO_printf(Perl_debug_log, "****\n");
9018 do_clean_objs(pTHXo_ SV *sv)
9022 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9023 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9024 if (SvWEAKREF(sv)) {
9035 /* XXX Might want to check arrays, etc. */
9038 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9040 do_clean_named_objs(pTHXo_ SV *sv)
9042 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9043 if ( SvOBJECT(GvSV(sv)) ||
9044 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9045 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9046 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9047 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9049 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9057 do_clean_all(pTHXo_ SV *sv)
9059 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9060 SvFLAGS(sv) |= SVf_BREAK;