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);
1840 /* Hopefully trace flow will optimise this away where possible
1846 /* It wasn't an integer, or it overflowed, or we don't have
1847 strtol. Do things the slow way - check if it's a UV etc. */
1848 d = Atof(SvPVX(sv));
1850 if (SvTYPE(sv) < SVt_PVNV)
1851 sv_upgrade(sv, SVt_PVNV);
1854 if (! numtype && ckWARN(WARN_NUMERIC))
1857 #if defined(USE_LONG_DOUBLE)
1858 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1859 PTR2UV(sv), SvNVX(sv)));
1861 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1862 PTR2UV(sv), SvNVX(sv)));
1866 #ifdef NV_PRESERVES_UV
1867 (void)SvIOKp_on(sv);
1869 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1870 SvIVX(sv) = I_V(SvNVX(sv));
1871 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1874 /* Integer is imprecise. NOK, IOKp */
1876 /* UV will not work better than IV */
1878 if (SvNVX(sv) > (NV)UV_MAX) {
1880 /* Integer is inaccurate. NOK, IOKp, is UV */
1884 SvUVX(sv) = U_V(SvNVX(sv));
1885 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1886 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1890 /* Integer is imprecise. NOK, IOKp, is UV */
1896 #else /* NV_PRESERVES_UV */
1897 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1898 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1899 /* Small enough to preserve all bits. */
1900 (void)SvIOKp_on(sv);
1902 SvIVX(sv) = I_V(SvNVX(sv));
1903 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1905 /* Assumption: first non-preserved integer is < IV_MAX,
1906 this NV is in the preserved range, therefore: */
1907 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1909 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);
1911 } else if (sv_2iuv_non_preserve (sv, numtype)
1912 >= IS_NUMBER_OVERFLOW_IV)
1914 #endif /* NV_PRESERVES_UV */
1918 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1920 if (SvTYPE(sv) < SVt_IV)
1921 /* Typically the caller expects that sv_any is not NULL now. */
1922 sv_upgrade(sv, SVt_IV);
1925 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1926 PTR2UV(sv),SvIVX(sv)));
1927 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1931 Perl_sv_2uv(pTHX_ register SV *sv)
1935 if (SvGMAGICAL(sv)) {
1940 return U_V(SvNVX(sv));
1941 if (SvPOKp(sv) && SvLEN(sv))
1944 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1945 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1951 if (SvTHINKFIRST(sv)) {
1954 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1955 (SvRV(tmpstr) != SvRV(sv)))
1956 return SvUV(tmpstr);
1957 return PTR2UV(SvRV(sv));
1959 if (SvREADONLY(sv) && SvFAKE(sv)) {
1960 sv_force_normal(sv);
1962 if (SvREADONLY(sv) && !SvOK(sv)) {
1963 if (ckWARN(WARN_UNINITIALIZED))
1973 return (UV)SvIVX(sv);
1977 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1978 * without also getting a cached IV/UV from it at the same time
1979 * (ie PV->NV conversion should detect loss of accuracy and cache
1980 * IV or UV at same time to avoid this. */
1981 /* IV-over-UV optimisation - choose to cache IV if possible */
1983 if (SvTYPE(sv) == SVt_NV)
1984 sv_upgrade(sv, SVt_PVNV);
1986 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1987 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1988 SvIVX(sv) = I_V(SvNVX(sv));
1989 if (SvNVX(sv) == (NV) SvIVX(sv)
1990 #ifndef NV_PRESERVES_UV
1991 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1992 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1993 /* Don't flag it as "accurately an integer" if the number
1994 came from a (by definition imprecise) NV operation, and
1995 we're outside the range of NV integer precision */
1998 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1999 DEBUG_c(PerlIO_printf(Perl_debug_log,
2000 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2006 /* IV not precise. No need to convert from PV, as NV
2007 conversion would already have cached IV if it detected
2008 that PV->IV would be better than PV->NV->IV
2009 flags already correct - don't set public IOK. */
2010 DEBUG_c(PerlIO_printf(Perl_debug_log,
2011 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2016 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2017 but the cast (NV)IV_MIN rounds to a the value less (more
2018 negative) than IV_MIN which happens to be equal to SvNVX ??
2019 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2020 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2021 (NV)UVX == NVX are both true, but the values differ. :-(
2022 Hopefully for 2s complement IV_MIN is something like
2023 0x8000000000000000 which will be exact. NWC */
2026 SvUVX(sv) = U_V(SvNVX(sv));
2028 (SvNVX(sv) == (NV) SvUVX(sv))
2029 #ifndef NV_PRESERVES_UV
2030 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2031 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2032 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2033 /* Don't flag it as "accurately an integer" if the number
2034 came from a (by definition imprecise) NV operation, and
2035 we're outside the range of NV integer precision */
2040 DEBUG_c(PerlIO_printf(Perl_debug_log,
2041 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2047 else if (SvPOKp(sv) && SvLEN(sv)) {
2048 I32 numtype = looks_like_number(sv);
2050 /* We want to avoid a possible problem when we cache a UV which
2051 may be later translated to an NV, and the resulting NV is not
2052 the translation of the initial data.
2054 This means that if we cache such a UV, we need to cache the
2055 NV as well. Moreover, we trade speed for space, and do not
2056 cache the NV if not needed.
2059 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2060 /* The NV may be reconstructed from IV - safe to cache IV,
2061 which may be calculated by atol(). */
2062 if (SvTYPE(sv) < SVt_PVIV)
2063 sv_upgrade(sv, SVt_PVIV);
2065 SvIVX(sv) = Atol(SvPVX(sv));
2069 int save_errno = errno;
2070 /* Is it an integer that we could convert with strtoul?
2071 So try it, and if it doesn't set errno then it's pukka.
2072 This should be faster than going atof and then thinking. */
2073 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2074 == IS_NUMBER_TO_INT_BY_STRTOL)
2075 && ((errno = 0), 1) /* always true */
2076 && ((u = Strtoul(SvPVX(sv), Null(char**), 10)), 1) /* ditto */
2078 /* If known to be negative, check it didn't undeflow IV */
2079 && ((numtype & IS_NUMBER_NEG) ? ((IV)u <= 0) : 1)) {
2082 if (SvTYPE(sv) < SVt_PVIV)
2083 sv_upgrade(sv, SVt_PVIV);
2086 /* If it's negative must use IV.
2087 IV-over-UV optimisation */
2088 if (numtype & IS_NUMBER_NEG || u <= (UV) IV_MAX) {
2089 /* strtoul is defined to return negated value if the
2090 number starts with a minus sign. Assuming 2s
2091 complement, this value will be in range for a negative
2092 IV if casting the bit pattern to IV doesn't produce
2093 a positive value. Allow -0 by checking it's <= 0
2094 hence (numtype & IS_NUMBER_NEG) test above
2098 /* it didn't overflow, and it was positive. */
2104 /* Hopefully trace flow will optimise this away where possible
2110 /* It wasn't an integer, or it overflowed, or we don't have
2111 strtol. Do things the slow way - check if it's a IV etc. */
2112 d = Atof(SvPVX(sv));
2114 if (SvTYPE(sv) < SVt_PVNV)
2115 sv_upgrade(sv, SVt_PVNV);
2118 if (! numtype && ckWARN(WARN_NUMERIC))
2121 #if defined(USE_LONG_DOUBLE)
2122 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2123 PTR2UV(sv), SvNVX(sv)));
2125 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2126 PTR2UV(sv), SvNVX(sv)));
2129 #ifdef NV_PRESERVES_UV
2130 (void)SvIOKp_on(sv);
2132 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2133 SvIVX(sv) = I_V(SvNVX(sv));
2134 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2137 /* Integer is imprecise. NOK, IOKp */
2139 /* UV will not work better than IV */
2141 if (SvNVX(sv) > (NV)UV_MAX) {
2143 /* Integer is inaccurate. NOK, IOKp, is UV */
2147 SvUVX(sv) = U_V(SvNVX(sv));
2148 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2149 NV preservse UV so can do correct comparison. */
2150 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2154 /* Integer is imprecise. NOK, IOKp, is UV */
2159 #else /* NV_PRESERVES_UV */
2160 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2161 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2162 /* Small enough to preserve all bits. */
2163 (void)SvIOKp_on(sv);
2165 SvIVX(sv) = I_V(SvNVX(sv));
2166 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2168 /* Assumption: first non-preserved integer is < IV_MAX,
2169 this NV is in the preserved range, therefore: */
2170 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2172 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);
2175 sv_2iuv_non_preserve (sv, numtype);
2176 #endif /* NV_PRESERVES_UV */
2181 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2182 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2185 if (SvTYPE(sv) < SVt_IV)
2186 /* Typically the caller expects that sv_any is not NULL now. */
2187 sv_upgrade(sv, SVt_IV);
2191 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2192 PTR2UV(sv),SvUVX(sv)));
2193 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2197 Perl_sv_2nv(pTHX_ register SV *sv)
2201 if (SvGMAGICAL(sv)) {
2205 if (SvPOKp(sv) && SvLEN(sv)) {
2206 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2208 return Atof(SvPVX(sv));
2212 return (NV)SvUVX(sv);
2214 return (NV)SvIVX(sv);
2217 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2218 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2224 if (SvTHINKFIRST(sv)) {
2227 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2228 (SvRV(tmpstr) != SvRV(sv)))
2229 return SvNV(tmpstr);
2230 return PTR2NV(SvRV(sv));
2232 if (SvREADONLY(sv) && SvFAKE(sv)) {
2233 sv_force_normal(sv);
2235 if (SvREADONLY(sv) && !SvOK(sv)) {
2236 if (ckWARN(WARN_UNINITIALIZED))
2241 if (SvTYPE(sv) < SVt_NV) {
2242 if (SvTYPE(sv) == SVt_IV)
2243 sv_upgrade(sv, SVt_PVNV);
2245 sv_upgrade(sv, SVt_NV);
2246 #if defined(USE_LONG_DOUBLE)
2248 STORE_NUMERIC_LOCAL_SET_STANDARD();
2249 PerlIO_printf(Perl_debug_log,
2250 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2251 PTR2UV(sv), SvNVX(sv));
2252 RESTORE_NUMERIC_LOCAL();
2256 STORE_NUMERIC_LOCAL_SET_STANDARD();
2257 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2258 PTR2UV(sv), SvNVX(sv));
2259 RESTORE_NUMERIC_LOCAL();
2263 else if (SvTYPE(sv) < SVt_PVNV)
2264 sv_upgrade(sv, SVt_PVNV);
2266 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2268 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2269 #ifdef NV_PRESERVES_UV
2272 /* Only set the public NV OK flag if this NV preserves the IV */
2273 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2274 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2275 : (SvIVX(sv) == I_V(SvNVX(sv))))
2281 else if (SvPOKp(sv) && SvLEN(sv)) {
2282 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2284 SvNVX(sv) = Atof(SvPVX(sv));
2285 #ifdef NV_PRESERVES_UV
2288 /* Only set the public NV OK flag if this NV preserves the value in
2289 the PV at least as well as an IV/UV would.
2290 Not sure how to do this 100% reliably. */
2291 /* if that shift count is out of range then Configure's test is
2292 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2294 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2295 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2296 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2297 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2298 /* Definitely too large/small to fit in an integer, so no loss
2299 of precision going to integer in the future via NV */
2302 /* Is it something we can run through strtol etc (ie no
2303 trailing exponent part)? */
2304 int numtype = looks_like_number(sv);
2305 /* XXX probably should cache this if called above */
2308 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2309 /* Can't use strtol etc to convert this string, so don't try */
2312 sv_2inuv_non_preserve (sv, numtype);
2314 #endif /* NV_PRESERVES_UV */
2317 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2319 if (SvTYPE(sv) < SVt_NV)
2320 /* Typically the caller expects that sv_any is not NULL now. */
2321 /* XXX Ilya implies that this is a bug in callers that assume this
2322 and ideally should be fixed. */
2323 sv_upgrade(sv, SVt_NV);
2326 #if defined(USE_LONG_DOUBLE)
2328 STORE_NUMERIC_LOCAL_SET_STANDARD();
2329 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2330 PTR2UV(sv), SvNVX(sv));
2331 RESTORE_NUMERIC_LOCAL();
2335 STORE_NUMERIC_LOCAL_SET_STANDARD();
2336 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2337 PTR2UV(sv), SvNVX(sv));
2338 RESTORE_NUMERIC_LOCAL();
2345 S_asIV(pTHX_ SV *sv)
2347 I32 numtype = looks_like_number(sv);
2350 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2351 return Atol(SvPVX(sv));
2353 if (ckWARN(WARN_NUMERIC))
2356 d = Atof(SvPVX(sv));
2361 S_asUV(pTHX_ SV *sv)
2363 I32 numtype = looks_like_number(sv);
2366 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2367 return Strtoul(SvPVX(sv), Null(char**), 10);
2370 if (ckWARN(WARN_NUMERIC))
2373 return U_V(Atof(SvPVX(sv)));
2377 * Returns a combination of (advisory only - can get false negatives)
2378 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2379 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2380 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2381 * 0 if does not look like number.
2383 * (atol and strtol stop when they hit a decimal point. strtol will return
2384 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2385 * do this, and vendors have had 11 years to get it right.
2386 * However, will try to make it still work with only atol
2388 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2389 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2390 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2391 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2392 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2393 * IS_NUMBER_NOT_INT saw "." or "e"
2395 * IS_NUMBER_INFINITY
2399 =for apidoc looks_like_number
2401 Test if an the content of an SV looks like a number (or is a
2402 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2403 issue a non-numeric warning), even if your atof() doesn't grok them.
2409 Perl_looks_like_number(pTHX_ SV *sv)
2412 register char *send;
2413 register char *sbegin;
2414 register char *nbegin;
2423 else if (SvPOKp(sv))
2424 sbegin = SvPV(sv, len);
2427 send = sbegin + len;
2434 numtype = IS_NUMBER_NEG;
2441 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2442 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2443 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2444 * will need (int)atof().
2447 /* next must be digit or the radix separator or beginning of infinity */
2451 } while (isDIGIT(*s));
2453 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2454 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2455 else if (s - nbegin < BIT_DIGITS(sizeof (IV)*8-1))
2456 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2458 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2459 digit less (IV_MAX= 9223372036854775807,
2460 UV_MAX= 18446744073709551615) so be cautious */
2461 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2464 #ifdef USE_LOCALE_NUMERIC
2465 || IS_NUMERIC_RADIX(*s)
2469 numtype |= IS_NUMBER_NOT_INT;
2470 while (isDIGIT(*s)) /* optional digits after the radix */
2475 #ifdef USE_LOCALE_NUMERIC
2476 || IS_NUMERIC_RADIX(*s)
2480 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2481 /* no digits before the radix means we need digits after it */
2485 } while (isDIGIT(*s));
2490 else if (*s == 'I' || *s == 'i') {
2491 s++; if (*s != 'N' && *s != 'n') return 0;
2492 s++; if (*s != 'F' && *s != 'f') return 0;
2493 s++; if (*s == 'I' || *s == 'i') {
2494 s++; if (*s != 'N' && *s != 'n') return 0;
2495 s++; if (*s != 'I' && *s != 'i') return 0;
2496 s++; if (*s != 'T' && *s != 't') return 0;
2497 s++; if (*s != 'Y' && *s != 'y') return 0;
2506 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2507 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2509 /* we can have an optional exponent part */
2510 if (*s == 'e' || *s == 'E') {
2511 numtype &= IS_NUMBER_NEG;
2512 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2514 if (*s == '+' || *s == '-')
2519 } while (isDIGIT(*s));
2529 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2530 return IS_NUMBER_TO_INT_BY_ATOL;
2535 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2538 return sv_2pv(sv, &n_a);
2541 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2543 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2545 char *ptr = buf + TYPE_CHARS(UV);
2559 *--ptr = '0' + (uv % 10);
2568 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2573 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2574 char *tmpbuf = tbuf;
2580 if (SvGMAGICAL(sv)) {
2588 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2590 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2595 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2600 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2601 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2608 if (SvTHINKFIRST(sv)) {
2611 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2612 (SvRV(tmpstr) != SvRV(sv)))
2613 return SvPV(tmpstr,*lp);
2620 switch (SvTYPE(sv)) {
2622 if ( ((SvFLAGS(sv) &
2623 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2624 == (SVs_OBJECT|SVs_RMG))
2625 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2626 && (mg = mg_find(sv, 'r'))) {
2627 regexp *re = (regexp *)mg->mg_obj;
2630 char *fptr = "msix";
2635 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2637 while((ch = *fptr++)) {
2639 reflags[left++] = ch;
2642 reflags[right--] = ch;
2647 reflags[left] = '-';
2651 mg->mg_len = re->prelen + 4 + left;
2652 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2653 Copy("(?", mg->mg_ptr, 2, char);
2654 Copy(reflags, mg->mg_ptr+2, left, char);
2655 Copy(":", mg->mg_ptr+left+2, 1, char);
2656 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2657 mg->mg_ptr[mg->mg_len - 1] = ')';
2658 mg->mg_ptr[mg->mg_len] = 0;
2660 PL_reginterp_cnt += re->program[0].next_off;
2672 case SVt_PVBM: if (SvROK(sv))
2675 s = "SCALAR"; break;
2676 case SVt_PVLV: s = "LVALUE"; break;
2677 case SVt_PVAV: s = "ARRAY"; break;
2678 case SVt_PVHV: s = "HASH"; break;
2679 case SVt_PVCV: s = "CODE"; break;
2680 case SVt_PVGV: s = "GLOB"; break;
2681 case SVt_PVFM: s = "FORMAT"; break;
2682 case SVt_PVIO: s = "IO"; break;
2683 default: s = "UNKNOWN"; break;
2687 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2690 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2696 if (SvREADONLY(sv) && !SvOK(sv)) {
2697 if (ckWARN(WARN_UNINITIALIZED))
2703 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2704 /* I'm assuming that if both IV and NV are equally valid then
2705 converting the IV is going to be more efficient */
2706 U32 isIOK = SvIOK(sv);
2707 U32 isUIOK = SvIsUV(sv);
2708 char buf[TYPE_CHARS(UV)];
2711 if (SvTYPE(sv) < SVt_PVIV)
2712 sv_upgrade(sv, SVt_PVIV);
2714 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2716 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2717 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2718 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2719 SvCUR_set(sv, ebuf - ptr);
2729 else if (SvNOKp(sv)) {
2730 if (SvTYPE(sv) < SVt_PVNV)
2731 sv_upgrade(sv, SVt_PVNV);
2732 /* The +20 is pure guesswork. Configure test needed. --jhi */
2733 SvGROW(sv, NV_DIG + 20);
2735 olderrno = errno; /* some Xenix systems wipe out errno here */
2737 if (SvNVX(sv) == 0.0)
2738 (void)strcpy(s,"0");
2742 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2745 #ifdef FIXNEGATIVEZERO
2746 if (*s == '-' && s[1] == '0' && !s[2])
2756 if (ckWARN(WARN_UNINITIALIZED)
2757 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2760 if (SvTYPE(sv) < SVt_PV)
2761 /* Typically the caller expects that sv_any is not NULL now. */
2762 sv_upgrade(sv, SVt_PV);
2765 *lp = s - SvPVX(sv);
2768 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2769 PTR2UV(sv),SvPVX(sv)));
2773 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2774 /* Sneaky stuff here */
2778 tsv = newSVpv(tmpbuf, 0);
2794 len = strlen(tmpbuf);
2796 #ifdef FIXNEGATIVEZERO
2797 if (len == 2 && t[0] == '-' && t[1] == '0') {
2802 (void)SvUPGRADE(sv, SVt_PV);
2804 s = SvGROW(sv, len + 1);
2813 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2816 return sv_2pvbyte(sv, &n_a);
2820 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2822 return sv_2pv(sv,lp);
2826 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2829 return sv_2pvutf8(sv, &n_a);
2833 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2835 sv_utf8_upgrade(sv);
2836 return SvPV(sv,*lp);
2839 /* This function is only called on magical items */
2841 Perl_sv_2bool(pTHX_ register SV *sv)
2850 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2851 (SvRV(tmpsv) != SvRV(sv)))
2852 return SvTRUE(tmpsv);
2853 return SvRV(sv) != 0;
2856 register XPV* Xpvtmp;
2857 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2858 (*Xpvtmp->xpv_pv > '0' ||
2859 Xpvtmp->xpv_cur > 1 ||
2860 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2867 return SvIVX(sv) != 0;
2870 return SvNVX(sv) != 0.0;
2878 =for apidoc sv_utf8_upgrade
2880 Convert the PV of an SV to its UTF8-encoded form.
2886 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2891 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2894 /* This function could be much more efficient if we had a FLAG in SVs
2895 * to signal if there are any hibit chars in the PV.
2896 * Given that there isn't make loop fast as possible
2902 if ((hibit = *t++ & 0x80))
2908 if (SvREADONLY(sv) && SvFAKE(sv)) {
2909 sv_force_normal(sv);
2912 len = SvCUR(sv) + 1; /* Plus the \0 */
2913 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2914 SvCUR(sv) = len - 1;
2916 Safefree(s); /* No longer using what was there before. */
2917 SvLEN(sv) = len; /* No longer know the real size. */
2923 =for apidoc sv_utf8_downgrade
2925 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2926 This may not be possible if the PV contains non-byte encoding characters;
2927 if this is the case, either returns false or, if C<fail_ok> is not
2934 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2936 if (SvPOK(sv) && SvUTF8(sv)) {
2938 char *c = SvPVX(sv);
2939 STRLEN len = SvCUR(sv);
2941 if (!utf8_to_bytes((U8*)c, &len)) {
2946 Perl_croak(aTHX_ "Wide character in %s",
2947 PL_op_desc[PL_op->op_type]);
2949 Perl_croak(aTHX_ "Wide character");
2961 =for apidoc sv_utf8_encode
2963 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
2964 flag so that it looks like bytes again. Nothing calls this.
2970 Perl_sv_utf8_encode(pTHX_ register SV *sv)
2972 sv_utf8_upgrade(sv);
2977 Perl_sv_utf8_decode(pTHX_ register SV *sv)
2982 bool has_utf = FALSE;
2983 if (!sv_utf8_downgrade(sv, TRUE))
2986 /* it is actually just a matter of turning the utf8 flag on, but
2987 * we want to make sure everything inside is valid utf8 first.
2990 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
3004 /* Note: sv_setsv() should not be called with a source string that needs
3005 * to be reused, since it may destroy the source string if it is marked
3010 =for apidoc sv_setsv
3012 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3013 The source SV may be destroyed if it is mortal. Does not handle 'set'
3014 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3021 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3023 register U32 sflags;
3029 SV_CHECK_THINKFIRST(dstr);
3031 sstr = &PL_sv_undef;
3032 stype = SvTYPE(sstr);
3033 dtype = SvTYPE(dstr);
3037 /* There's a lot of redundancy below but we're going for speed here */
3042 if (dtype != SVt_PVGV) {
3043 (void)SvOK_off(dstr);
3051 sv_upgrade(dstr, SVt_IV);
3054 sv_upgrade(dstr, SVt_PVNV);
3058 sv_upgrade(dstr, SVt_PVIV);
3061 (void)SvIOK_only(dstr);
3062 SvIVX(dstr) = SvIVX(sstr);
3065 if (SvTAINTED(sstr))
3076 sv_upgrade(dstr, SVt_NV);
3081 sv_upgrade(dstr, SVt_PVNV);
3084 SvNVX(dstr) = SvNVX(sstr);
3085 (void)SvNOK_only(dstr);
3086 if (SvTAINTED(sstr))
3094 sv_upgrade(dstr, SVt_RV);
3095 else if (dtype == SVt_PVGV &&
3096 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3099 if (GvIMPORTED(dstr) != GVf_IMPORTED
3100 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3102 GvIMPORTED_on(dstr);
3113 sv_upgrade(dstr, SVt_PV);
3116 if (dtype < SVt_PVIV)
3117 sv_upgrade(dstr, SVt_PVIV);
3120 if (dtype < SVt_PVNV)
3121 sv_upgrade(dstr, SVt_PVNV);
3128 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3129 PL_op_name[PL_op->op_type]);
3131 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3135 if (dtype <= SVt_PVGV) {
3137 if (dtype != SVt_PVGV) {
3138 char *name = GvNAME(sstr);
3139 STRLEN len = GvNAMELEN(sstr);
3140 sv_upgrade(dstr, SVt_PVGV);
3141 sv_magic(dstr, dstr, '*', Nullch, 0);
3142 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3143 GvNAME(dstr) = savepvn(name, len);
3144 GvNAMELEN(dstr) = len;
3145 SvFAKE_on(dstr); /* can coerce to non-glob */
3147 /* ahem, death to those who redefine active sort subs */
3148 else if (PL_curstackinfo->si_type == PERLSI_SORT
3149 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3150 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3152 (void)SvOK_off(dstr);
3153 GvINTRO_off(dstr); /* one-shot flag */
3155 GvGP(dstr) = gp_ref(GvGP(sstr));
3156 if (SvTAINTED(sstr))
3158 if (GvIMPORTED(dstr) != GVf_IMPORTED
3159 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3161 GvIMPORTED_on(dstr);
3169 if (SvGMAGICAL(sstr)) {
3171 if (SvTYPE(sstr) != stype) {
3172 stype = SvTYPE(sstr);
3173 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3177 if (stype == SVt_PVLV)
3178 (void)SvUPGRADE(dstr, SVt_PVNV);
3180 (void)SvUPGRADE(dstr, stype);
3183 sflags = SvFLAGS(sstr);
3185 if (sflags & SVf_ROK) {
3186 if (dtype >= SVt_PV) {
3187 if (dtype == SVt_PVGV) {
3188 SV *sref = SvREFCNT_inc(SvRV(sstr));
3190 int intro = GvINTRO(dstr);
3195 GvINTRO_off(dstr); /* one-shot flag */
3196 Newz(602,gp, 1, GP);
3197 GvGP(dstr) = gp_ref(gp);
3198 GvSV(dstr) = NEWSV(72,0);
3199 GvLINE(dstr) = CopLINE(PL_curcop);
3200 GvEGV(dstr) = (GV*)dstr;
3203 switch (SvTYPE(sref)) {
3206 SAVESPTR(GvAV(dstr));
3208 dref = (SV*)GvAV(dstr);
3209 GvAV(dstr) = (AV*)sref;
3210 if (!GvIMPORTED_AV(dstr)
3211 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3213 GvIMPORTED_AV_on(dstr);
3218 SAVESPTR(GvHV(dstr));
3220 dref = (SV*)GvHV(dstr);
3221 GvHV(dstr) = (HV*)sref;
3222 if (!GvIMPORTED_HV(dstr)
3223 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3225 GvIMPORTED_HV_on(dstr);
3230 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3231 SvREFCNT_dec(GvCV(dstr));
3232 GvCV(dstr) = Nullcv;
3233 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3234 PL_sub_generation++;
3236 SAVESPTR(GvCV(dstr));
3239 dref = (SV*)GvCV(dstr);
3240 if (GvCV(dstr) != (CV*)sref) {
3241 CV* cv = GvCV(dstr);
3243 if (!GvCVGEN((GV*)dstr) &&
3244 (CvROOT(cv) || CvXSUB(cv)))
3247 /* ahem, death to those who redefine
3248 * active sort subs */
3249 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3250 PL_sortcop == CvSTART(cv))
3252 "Can't redefine active sort subroutine %s",
3253 GvENAME((GV*)dstr));
3254 /* Redefining a sub - warning is mandatory if
3255 it was a const and its value changed. */
3256 if (ckWARN(WARN_REDEFINE)
3258 && (!CvCONST((CV*)sref)
3259 || sv_cmp(cv_const_sv(cv),
3260 cv_const_sv((CV*)sref)))))
3262 Perl_warner(aTHX_ WARN_REDEFINE,
3264 ? "Constant subroutine %s redefined"
3265 : "Subroutine %s redefined",
3266 GvENAME((GV*)dstr));
3269 cv_ckproto(cv, (GV*)dstr,
3270 SvPOK(sref) ? SvPVX(sref) : Nullch);
3272 GvCV(dstr) = (CV*)sref;
3273 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3274 GvASSUMECV_on(dstr);
3275 PL_sub_generation++;
3277 if (!GvIMPORTED_CV(dstr)
3278 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3280 GvIMPORTED_CV_on(dstr);
3285 SAVESPTR(GvIOp(dstr));
3287 dref = (SV*)GvIOp(dstr);
3288 GvIOp(dstr) = (IO*)sref;
3292 SAVESPTR(GvFORM(dstr));
3294 dref = (SV*)GvFORM(dstr);
3295 GvFORM(dstr) = (CV*)sref;
3299 SAVESPTR(GvSV(dstr));
3301 dref = (SV*)GvSV(dstr);
3303 if (!GvIMPORTED_SV(dstr)
3304 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3306 GvIMPORTED_SV_on(dstr);
3314 if (SvTAINTED(sstr))
3319 (void)SvOOK_off(dstr); /* backoff */
3321 Safefree(SvPVX(dstr));
3322 SvLEN(dstr)=SvCUR(dstr)=0;
3325 (void)SvOK_off(dstr);
3326 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3328 if (sflags & SVp_NOK) {
3330 SvNVX(dstr) = SvNVX(sstr);
3332 if (sflags & SVp_IOK) {
3333 (void)SvIOK_on(dstr);
3334 SvIVX(dstr) = SvIVX(sstr);
3335 if (sflags & SVf_IVisUV)
3338 if (SvAMAGIC(sstr)) {
3342 else if (sflags & SVp_POK) {
3345 * Check to see if we can just swipe the string. If so, it's a
3346 * possible small lose on short strings, but a big win on long ones.
3347 * It might even be a win on short strings if SvPVX(dstr)
3348 * has to be allocated and SvPVX(sstr) has to be freed.
3351 if (SvTEMP(sstr) && /* slated for free anyway? */
3352 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3353 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3354 SvLEN(sstr) && /* and really is a string */
3355 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3357 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3359 SvFLAGS(dstr) &= ~SVf_OOK;
3360 Safefree(SvPVX(dstr) - SvIVX(dstr));
3362 else if (SvLEN(dstr))
3363 Safefree(SvPVX(dstr));
3365 (void)SvPOK_only(dstr);
3366 SvPV_set(dstr, SvPVX(sstr));
3367 SvLEN_set(dstr, SvLEN(sstr));
3368 SvCUR_set(dstr, SvCUR(sstr));
3371 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3372 SvPV_set(sstr, Nullch);
3377 else { /* have to copy actual string */
3378 STRLEN len = SvCUR(sstr);
3380 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3381 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3382 SvCUR_set(dstr, len);
3383 *SvEND(dstr) = '\0';
3384 (void)SvPOK_only(dstr);
3386 if ((sflags & SVf_UTF8) && !IN_BYTE)
3389 if (sflags & SVp_NOK) {
3391 SvNVX(dstr) = SvNVX(sstr);
3393 if (sflags & SVp_IOK) {
3394 (void)SvIOK_on(dstr);
3395 SvIVX(dstr) = SvIVX(sstr);
3396 if (sflags & SVf_IVisUV)
3400 else if (sflags & SVp_NOK) {
3401 SvNVX(dstr) = SvNVX(sstr);
3402 (void)SvNOK_only(dstr);
3403 if (sflags & SVf_IOK) {
3404 (void)SvIOK_on(dstr);
3405 SvIVX(dstr) = SvIVX(sstr);
3406 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3407 if (sflags & SVf_IVisUV)
3411 else if (sflags & SVp_IOK) {
3412 (void)SvIOK_only(dstr);
3413 SvIVX(dstr) = SvIVX(sstr);
3414 if (sflags & SVf_IVisUV)
3418 if (dtype == SVt_PVGV) {
3419 if (ckWARN(WARN_MISC))
3420 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3423 (void)SvOK_off(dstr);
3425 if (SvTAINTED(sstr))
3430 =for apidoc sv_setsv_mg
3432 Like C<sv_setsv>, but also handles 'set' magic.
3438 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3440 sv_setsv(dstr,sstr);
3445 =for apidoc sv_setpvn
3447 Copies a string into an SV. The C<len> parameter indicates the number of
3448 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3454 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3456 register char *dptr;
3458 /* len is STRLEN which is unsigned, need to copy to signed */
3462 SV_CHECK_THINKFIRST(sv);
3467 (void)SvUPGRADE(sv, SVt_PV);
3469 SvGROW(sv, len + 1);
3471 Move(ptr,dptr,len,char);
3474 (void)SvPOK_only(sv); /* validate pointer */
3479 =for apidoc sv_setpvn_mg
3481 Like C<sv_setpvn>, but also handles 'set' magic.
3487 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3489 sv_setpvn(sv,ptr,len);
3494 =for apidoc sv_setpv
3496 Copies a string into an SV. The string must be null-terminated. Does not
3497 handle 'set' magic. See C<sv_setpv_mg>.
3503 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3505 register STRLEN len;
3507 SV_CHECK_THINKFIRST(sv);
3513 (void)SvUPGRADE(sv, SVt_PV);
3515 SvGROW(sv, len + 1);
3516 Move(ptr,SvPVX(sv),len+1,char);
3518 (void)SvPOK_only(sv); /* validate pointer */
3523 =for apidoc sv_setpv_mg
3525 Like C<sv_setpv>, but also handles 'set' magic.
3531 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3538 =for apidoc sv_usepvn
3540 Tells an SV to use C<ptr> to find its string value. Normally the string is
3541 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3542 The C<ptr> should point to memory that was allocated by C<malloc>. The
3543 string length, C<len>, must be supplied. This function will realloc the
3544 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3545 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3546 See C<sv_usepvn_mg>.
3552 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3554 SV_CHECK_THINKFIRST(sv);
3555 (void)SvUPGRADE(sv, SVt_PV);
3560 (void)SvOOK_off(sv);
3561 if (SvPVX(sv) && SvLEN(sv))
3562 Safefree(SvPVX(sv));
3563 Renew(ptr, len+1, char);
3566 SvLEN_set(sv, len+1);
3568 (void)SvPOK_only(sv); /* validate pointer */
3573 =for apidoc sv_usepvn_mg
3575 Like C<sv_usepvn>, but also handles 'set' magic.
3581 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3583 sv_usepvn(sv,ptr,len);
3588 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3590 if (SvREADONLY(sv)) {
3592 char *pvx = SvPVX(sv);
3593 STRLEN len = SvCUR(sv);
3594 U32 hash = SvUVX(sv);
3595 SvGROW(sv, len + 1);
3596 Move(pvx,SvPVX(sv),len,char);
3600 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3602 else if (PL_curcop != &PL_compiling)
3603 Perl_croak(aTHX_ PL_no_modify);
3606 sv_unref_flags(sv, flags);
3607 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3612 Perl_sv_force_normal(pTHX_ register SV *sv)
3614 sv_force_normal_flags(sv, 0);
3620 Efficient removal of characters from the beginning of the string buffer.
3621 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3622 the string buffer. The C<ptr> becomes the first character of the adjusted
3629 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3633 register STRLEN delta;
3635 if (!ptr || !SvPOKp(sv))
3637 SV_CHECK_THINKFIRST(sv);
3638 if (SvTYPE(sv) < SVt_PVIV)
3639 sv_upgrade(sv,SVt_PVIV);
3642 if (!SvLEN(sv)) { /* make copy of shared string */
3643 char *pvx = SvPVX(sv);
3644 STRLEN len = SvCUR(sv);
3645 SvGROW(sv, len + 1);
3646 Move(pvx,SvPVX(sv),len,char);
3650 SvFLAGS(sv) |= SVf_OOK;
3652 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3653 delta = ptr - SvPVX(sv);
3661 =for apidoc sv_catpvn
3663 Concatenates the string onto the end of the string which is in the SV. The
3664 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3665 'set' magic. See C<sv_catpvn_mg>.
3671 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3676 junk = SvPV_force(sv, tlen);
3677 SvGROW(sv, tlen + len + 1);
3680 Move(ptr,SvPVX(sv)+tlen,len,char);
3683 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3688 =for apidoc sv_catpvn_mg
3690 Like C<sv_catpvn>, but also handles 'set' magic.
3696 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3698 sv_catpvn(sv,ptr,len);
3703 =for apidoc sv_catsv
3705 Concatenates the string from SV C<ssv> onto the end of the string in SV
3706 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3712 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3718 if ((s = SvPV(sstr, len))) {
3719 if (DO_UTF8(sstr)) {
3720 sv_utf8_upgrade(dstr);
3721 sv_catpvn(dstr,s,len);
3725 sv_catpvn(dstr,s,len);
3730 =for apidoc sv_catsv_mg
3732 Like C<sv_catsv>, but also handles 'set' magic.
3738 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3740 sv_catsv(dstr,sstr);
3745 =for apidoc sv_catpv
3747 Concatenates the string onto the end of the string which is in the SV.
3748 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3754 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3756 register STRLEN len;
3762 junk = SvPV_force(sv, tlen);
3764 SvGROW(sv, tlen + len + 1);
3767 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3769 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3774 =for apidoc sv_catpv_mg
3776 Like C<sv_catpv>, but also handles 'set' magic.
3782 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3789 Perl_newSV(pTHX_ STRLEN len)
3795 sv_upgrade(sv, SVt_PV);
3796 SvGROW(sv, len + 1);
3801 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3804 =for apidoc sv_magic
3806 Adds magic to an SV.
3812 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3816 if (SvREADONLY(sv)) {
3817 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3818 Perl_croak(aTHX_ PL_no_modify);
3820 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3821 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3828 (void)SvUPGRADE(sv, SVt_PVMG);
3830 Newz(702,mg, 1, MAGIC);
3831 mg->mg_moremagic = SvMAGIC(sv);
3834 if (!obj || obj == sv || how == '#' || how == 'r')
3837 mg->mg_obj = SvREFCNT_inc(obj);
3838 mg->mg_flags |= MGf_REFCOUNTED;
3841 mg->mg_len = namlen;
3844 mg->mg_ptr = savepvn(name, namlen);
3845 else if (namlen == HEf_SVKEY)
3846 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3850 mg->mg_virtual = &PL_vtbl_sv;
3853 mg->mg_virtual = &PL_vtbl_amagic;
3856 mg->mg_virtual = &PL_vtbl_amagicelem;
3862 mg->mg_virtual = &PL_vtbl_bm;
3865 mg->mg_virtual = &PL_vtbl_regdata;
3868 mg->mg_virtual = &PL_vtbl_regdatum;
3871 mg->mg_virtual = &PL_vtbl_env;
3874 mg->mg_virtual = &PL_vtbl_fm;
3877 mg->mg_virtual = &PL_vtbl_envelem;
3880 mg->mg_virtual = &PL_vtbl_mglob;
3883 mg->mg_virtual = &PL_vtbl_isa;
3886 mg->mg_virtual = &PL_vtbl_isaelem;
3889 mg->mg_virtual = &PL_vtbl_nkeys;
3896 mg->mg_virtual = &PL_vtbl_dbline;
3900 mg->mg_virtual = &PL_vtbl_mutex;
3902 #endif /* USE_THREADS */
3903 #ifdef USE_LOCALE_COLLATE
3905 mg->mg_virtual = &PL_vtbl_collxfrm;
3907 #endif /* USE_LOCALE_COLLATE */
3909 mg->mg_virtual = &PL_vtbl_pack;
3913 mg->mg_virtual = &PL_vtbl_packelem;
3916 mg->mg_virtual = &PL_vtbl_regexp;
3919 mg->mg_virtual = &PL_vtbl_sig;
3922 mg->mg_virtual = &PL_vtbl_sigelem;
3925 mg->mg_virtual = &PL_vtbl_taint;
3929 mg->mg_virtual = &PL_vtbl_uvar;
3932 mg->mg_virtual = &PL_vtbl_vec;
3935 mg->mg_virtual = &PL_vtbl_substr;
3938 mg->mg_virtual = &PL_vtbl_defelem;
3941 mg->mg_virtual = &PL_vtbl_glob;
3944 mg->mg_virtual = &PL_vtbl_arylen;
3947 mg->mg_virtual = &PL_vtbl_pos;
3950 mg->mg_virtual = &PL_vtbl_backref;
3952 case '~': /* Reserved for use by extensions not perl internals. */
3953 /* Useful for attaching extension internal data to perl vars. */
3954 /* Note that multiple extensions may clash if magical scalars */
3955 /* etc holding private data from one are passed to another. */
3959 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
3963 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
3967 =for apidoc sv_unmagic
3969 Removes magic from an SV.
3975 Perl_sv_unmagic(pTHX_ SV *sv, int type)
3979 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
3982 for (mg = *mgp; mg; mg = *mgp) {
3983 if (mg->mg_type == type) {
3984 MGVTBL* vtbl = mg->mg_virtual;
3985 *mgp = mg->mg_moremagic;
3986 if (vtbl && vtbl->svt_free)
3987 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
3988 if (mg->mg_ptr && mg->mg_type != 'g')
3989 if (mg->mg_len >= 0)
3990 Safefree(mg->mg_ptr);
3991 else if (mg->mg_len == HEf_SVKEY)
3992 SvREFCNT_dec((SV*)mg->mg_ptr);
3993 if (mg->mg_flags & MGf_REFCOUNTED)
3994 SvREFCNT_dec(mg->mg_obj);
3998 mgp = &mg->mg_moremagic;
4002 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4009 =for apidoc sv_rvweaken
4017 Perl_sv_rvweaken(pTHX_ SV *sv)
4020 if (!SvOK(sv)) /* let undefs pass */
4023 Perl_croak(aTHX_ "Can't weaken a nonreference");
4024 else if (SvWEAKREF(sv)) {
4025 if (ckWARN(WARN_MISC))
4026 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4030 sv_add_backref(tsv, sv);
4037 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4041 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4042 av = (AV*)mg->mg_obj;
4045 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4046 SvREFCNT_dec(av); /* for sv_magic */
4052 S_sv_del_backref(pTHX_ SV *sv)
4059 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4060 Perl_croak(aTHX_ "panic: del_backref");
4061 av = (AV *)mg->mg_obj;
4066 svp[i] = &PL_sv_undef; /* XXX */
4073 =for apidoc sv_insert
4075 Inserts a string at the specified offset/length within the SV. Similar to
4076 the Perl substr() function.
4082 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4086 register char *midend;
4087 register char *bigend;
4093 Perl_croak(aTHX_ "Can't modify non-existent substring");
4094 SvPV_force(bigstr, curlen);
4095 (void)SvPOK_only_UTF8(bigstr);
4096 if (offset + len > curlen) {
4097 SvGROW(bigstr, offset+len+1);
4098 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4099 SvCUR_set(bigstr, offset+len);
4103 i = littlelen - len;
4104 if (i > 0) { /* string might grow */
4105 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4106 mid = big + offset + len;
4107 midend = bigend = big + SvCUR(bigstr);
4110 while (midend > mid) /* shove everything down */
4111 *--bigend = *--midend;
4112 Move(little,big+offset,littlelen,char);
4118 Move(little,SvPVX(bigstr)+offset,len,char);
4123 big = SvPVX(bigstr);
4126 bigend = big + SvCUR(bigstr);
4128 if (midend > bigend)
4129 Perl_croak(aTHX_ "panic: sv_insert");
4131 if (mid - big > bigend - midend) { /* faster to shorten from end */
4133 Move(little, mid, littlelen,char);
4136 i = bigend - midend;
4138 Move(midend, mid, i,char);
4142 SvCUR_set(bigstr, mid - big);
4145 else if ((i = mid - big)) { /* faster from front */
4146 midend -= littlelen;
4148 sv_chop(bigstr,midend-i);
4153 Move(little, mid, littlelen,char);
4155 else if (littlelen) {
4156 midend -= littlelen;
4157 sv_chop(bigstr,midend);
4158 Move(little,midend,littlelen,char);
4161 sv_chop(bigstr,midend);
4167 =for apidoc sv_replace
4169 Make the first argument a copy of the second, then delete the original.
4175 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4177 U32 refcnt = SvREFCNT(sv);
4178 SV_CHECK_THINKFIRST(sv);
4179 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4180 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4181 if (SvMAGICAL(sv)) {
4185 sv_upgrade(nsv, SVt_PVMG);
4186 SvMAGIC(nsv) = SvMAGIC(sv);
4187 SvFLAGS(nsv) |= SvMAGICAL(sv);
4193 assert(!SvREFCNT(sv));
4194 StructCopy(nsv,sv,SV);
4195 SvREFCNT(sv) = refcnt;
4196 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4201 =for apidoc sv_clear
4203 Clear an SV, making it empty. Does not free the memory used by the SV
4210 Perl_sv_clear(pTHX_ register SV *sv)
4214 assert(SvREFCNT(sv) == 0);
4217 if (PL_defstash) { /* Still have a symbol table? */
4222 Zero(&tmpref, 1, SV);
4223 sv_upgrade(&tmpref, SVt_RV);
4225 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4226 SvREFCNT(&tmpref) = 1;
4229 stash = SvSTASH(sv);
4230 destructor = gv_fetchmethod(SvSTASH(sv), "DESTROY");
4233 PUSHSTACKi(PERLSI_DESTROY);
4234 SvRV(&tmpref) = SvREFCNT_inc(sv);
4239 call_sv((SV*)GvCV(destructor),
4240 G_DISCARD|G_EVAL|G_KEEPERR);
4246 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4248 del_XRV(SvANY(&tmpref));
4251 if (PL_in_clean_objs)
4252 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4254 /* DESTROY gave object new lease on life */
4260 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4261 SvOBJECT_off(sv); /* Curse the object. */
4262 if (SvTYPE(sv) != SVt_PVIO)
4263 --PL_sv_objcount; /* XXX Might want something more general */
4266 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4269 switch (SvTYPE(sv)) {
4272 IoIFP(sv) != PerlIO_stdin() &&
4273 IoIFP(sv) != PerlIO_stdout() &&
4274 IoIFP(sv) != PerlIO_stderr())
4276 io_close((IO*)sv, FALSE);
4278 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4279 PerlDir_close(IoDIRP(sv));
4280 IoDIRP(sv) = (DIR*)NULL;
4281 Safefree(IoTOP_NAME(sv));
4282 Safefree(IoFMT_NAME(sv));
4283 Safefree(IoBOTTOM_NAME(sv));
4298 SvREFCNT_dec(LvTARG(sv));
4302 Safefree(GvNAME(sv));
4303 /* cannot decrease stash refcount yet, as we might recursively delete
4304 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4305 of stash until current sv is completely gone.
4306 -- JohnPC, 27 Mar 1998 */
4307 stash = GvSTASH(sv);
4313 (void)SvOOK_off(sv);
4321 SvREFCNT_dec(SvRV(sv));
4323 else if (SvPVX(sv) && SvLEN(sv))
4324 Safefree(SvPVX(sv));
4325 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4326 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4338 switch (SvTYPE(sv)) {
4354 del_XPVIV(SvANY(sv));
4357 del_XPVNV(SvANY(sv));
4360 del_XPVMG(SvANY(sv));
4363 del_XPVLV(SvANY(sv));
4366 del_XPVAV(SvANY(sv));
4369 del_XPVHV(SvANY(sv));
4372 del_XPVCV(SvANY(sv));
4375 del_XPVGV(SvANY(sv));
4376 /* code duplication for increased performance. */
4377 SvFLAGS(sv) &= SVf_BREAK;
4378 SvFLAGS(sv) |= SVTYPEMASK;
4379 /* decrease refcount of the stash that owns this GV, if any */
4381 SvREFCNT_dec(stash);
4382 return; /* not break, SvFLAGS reset already happened */
4384 del_XPVBM(SvANY(sv));
4387 del_XPVFM(SvANY(sv));
4390 del_XPVIO(SvANY(sv));
4393 SvFLAGS(sv) &= SVf_BREAK;
4394 SvFLAGS(sv) |= SVTYPEMASK;
4398 Perl_sv_newref(pTHX_ SV *sv)
4401 ATOMIC_INC(SvREFCNT(sv));
4408 Free the memory used by an SV.
4414 Perl_sv_free(pTHX_ SV *sv)
4416 int refcount_is_zero;
4420 if (SvREFCNT(sv) == 0) {
4421 if (SvFLAGS(sv) & SVf_BREAK)
4423 if (PL_in_clean_all) /* All is fair */
4425 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4426 /* make sure SvREFCNT(sv)==0 happens very seldom */
4427 SvREFCNT(sv) = (~(U32)0)/2;
4430 if (ckWARN_d(WARN_INTERNAL))
4431 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4434 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4435 if (!refcount_is_zero)
4439 if (ckWARN_d(WARN_DEBUGGING))
4440 Perl_warner(aTHX_ WARN_DEBUGGING,
4441 "Attempt to free temp prematurely: SV 0x%"UVxf,
4446 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4447 /* make sure SvREFCNT(sv)==0 happens very seldom */
4448 SvREFCNT(sv) = (~(U32)0)/2;
4459 Returns the length of the string in the SV. See also C<SvCUR>.
4465 Perl_sv_len(pTHX_ register SV *sv)
4474 len = mg_length(sv);
4476 junk = SvPV(sv, len);
4481 =for apidoc sv_len_utf8
4483 Returns the number of characters in the string in an SV, counting wide
4484 UTF8 bytes as a single character.
4490 Perl_sv_len_utf8(pTHX_ register SV *sv)
4497 return mg_length(sv);
4502 U8 *s = (U8*)SvPV(sv, len);
4504 return Perl_utf8_length(aTHX_ s, s + len);
4509 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4514 I32 uoffset = *offsetp;
4520 start = s = (U8*)SvPV(sv, len);
4522 while (s < send && uoffset--)
4526 *offsetp = s - start;
4530 while (s < send && ulen--)
4540 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4549 s = (U8*)SvPV(sv, len);
4551 Perl_croak(aTHX_ "panic: bad byte offset");
4552 send = s + *offsetp;
4559 if (ckWARN_d(WARN_UTF8))
4560 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4570 Returns a boolean indicating whether the strings in the two SVs are
4577 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4584 bool pv1tmp = FALSE;
4585 bool pv2tmp = FALSE;
4592 pv1 = SvPV(sv1, cur1);
4599 pv2 = SvPV(sv2, cur2);
4601 /* do not utf8ize the comparands as a side-effect */
4602 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4604 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4608 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4614 eq = memEQ(pv1, pv2, cur1);
4627 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4628 string in C<sv1> is less than, equal to, or greater than the string in
4635 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4640 bool pv1tmp = FALSE;
4641 bool pv2tmp = FALSE;
4648 pv1 = SvPV(sv1, cur1);
4655 pv2 = SvPV(sv2, cur2);
4657 /* do not utf8ize the comparands as a side-effect */
4658 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4660 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4664 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4670 cmp = cur2 ? -1 : 0;
4674 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4677 cmp = retval < 0 ? -1 : 1;
4678 } else if (cur1 == cur2) {
4681 cmp = cur1 < cur2 ? -1 : 1;
4694 =for apidoc sv_cmp_locale
4696 Compares the strings in two SVs in a locale-aware manner. See
4703 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4705 #ifdef USE_LOCALE_COLLATE
4711 if (PL_collation_standard)
4715 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4717 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4719 if (!pv1 || !len1) {
4730 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4733 return retval < 0 ? -1 : 1;
4736 * When the result of collation is equality, that doesn't mean
4737 * that there are no differences -- some locales exclude some
4738 * characters from consideration. So to avoid false equalities,
4739 * we use the raw string as a tiebreaker.
4745 #endif /* USE_LOCALE_COLLATE */
4747 return sv_cmp(sv1, sv2);
4750 #ifdef USE_LOCALE_COLLATE
4752 * Any scalar variable may carry an 'o' magic that contains the
4753 * scalar data of the variable transformed to such a format that
4754 * a normal memory comparison can be used to compare the data
4755 * according to the locale settings.
4758 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4762 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4763 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4768 Safefree(mg->mg_ptr);
4770 if ((xf = mem_collxfrm(s, len, &xlen))) {
4771 if (SvREADONLY(sv)) {
4774 return xf + sizeof(PL_collation_ix);
4777 sv_magic(sv, 0, 'o', 0, 0);
4778 mg = mg_find(sv, 'o');
4791 if (mg && mg->mg_ptr) {
4793 return mg->mg_ptr + sizeof(PL_collation_ix);
4801 #endif /* USE_LOCALE_COLLATE */
4806 Get a line from the filehandle and store it into the SV, optionally
4807 appending to the currently-stored string.
4813 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4817 register STDCHAR rslast;
4818 register STDCHAR *bp;
4822 SV_CHECK_THINKFIRST(sv);
4823 (void)SvUPGRADE(sv, SVt_PV);
4827 if (RsSNARF(PL_rs)) {
4831 else if (RsRECORD(PL_rs)) {
4832 I32 recsize, bytesread;
4835 /* Grab the size of the record we're getting */
4836 recsize = SvIV(SvRV(PL_rs));
4837 (void)SvPOK_only(sv); /* Validate pointer */
4838 buffer = SvGROW(sv, recsize + 1);
4841 /* VMS wants read instead of fread, because fread doesn't respect */
4842 /* RMS record boundaries. This is not necessarily a good thing to be */
4843 /* doing, but we've got no other real choice */
4844 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4846 bytesread = PerlIO_read(fp, buffer, recsize);
4848 SvCUR_set(sv, bytesread);
4849 buffer[bytesread] = '\0';
4850 if (PerlIO_isutf8(fp))
4854 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4856 else if (RsPARA(PL_rs)) {
4861 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4862 if (PerlIO_isutf8(fp)) {
4863 rsptr = SvPVutf8(PL_rs, rslen);
4866 if (SvUTF8(PL_rs)) {
4867 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4868 Perl_croak(aTHX_ "Wide character in $/");
4871 rsptr = SvPV(PL_rs, rslen);
4875 rslast = rslen ? rsptr[rslen - 1] : '\0';
4877 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4878 do { /* to make sure file boundaries work right */
4881 i = PerlIO_getc(fp);
4885 PerlIO_ungetc(fp,i);
4891 /* See if we know enough about I/O mechanism to cheat it ! */
4893 /* This used to be #ifdef test - it is made run-time test for ease
4894 of abstracting out stdio interface. One call should be cheap
4895 enough here - and may even be a macro allowing compile
4899 if (PerlIO_fast_gets(fp)) {
4902 * We're going to steal some values from the stdio struct
4903 * and put EVERYTHING in the innermost loop into registers.
4905 register STDCHAR *ptr;
4909 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4910 /* An ungetc()d char is handled separately from the regular
4911 * buffer, so we getc() it back out and stuff it in the buffer.
4913 i = PerlIO_getc(fp);
4914 if (i == EOF) return 0;
4915 *(--((*fp)->_ptr)) = (unsigned char) i;
4919 /* Here is some breathtakingly efficient cheating */
4921 cnt = PerlIO_get_cnt(fp); /* get count into register */
4922 (void)SvPOK_only(sv); /* validate pointer */
4923 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4924 if (cnt > 80 && SvLEN(sv) > append) {
4925 shortbuffered = cnt - SvLEN(sv) + append + 1;
4926 cnt -= shortbuffered;
4930 /* remember that cnt can be negative */
4931 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4936 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4937 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4938 DEBUG_P(PerlIO_printf(Perl_debug_log,
4939 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4940 DEBUG_P(PerlIO_printf(Perl_debug_log,
4941 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4942 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4943 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
4948 while (cnt > 0) { /* this | eat */
4950 if ((*bp++ = *ptr++) == rslast) /* really | dust */
4951 goto thats_all_folks; /* screams | sed :-) */
4955 Copy(ptr, bp, cnt, char); /* this | eat */
4956 bp += cnt; /* screams | dust */
4957 ptr += cnt; /* louder | sed :-) */
4962 if (shortbuffered) { /* oh well, must extend */
4963 cnt = shortbuffered;
4965 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4967 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
4968 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
4972 DEBUG_P(PerlIO_printf(Perl_debug_log,
4973 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
4974 PTR2UV(ptr),(long)cnt));
4975 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
4976 DEBUG_P(PerlIO_printf(Perl_debug_log,
4977 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4978 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4979 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4980 /* This used to call 'filbuf' in stdio form, but as that behaves like
4981 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
4982 another abstraction. */
4983 i = PerlIO_getc(fp); /* get more characters */
4984 DEBUG_P(PerlIO_printf(Perl_debug_log,
4985 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
4986 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
4987 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
4988 cnt = PerlIO_get_cnt(fp);
4989 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
4990 DEBUG_P(PerlIO_printf(Perl_debug_log,
4991 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4993 if (i == EOF) /* all done for ever? */
4994 goto thats_really_all_folks;
4996 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
4998 SvGROW(sv, bpx + cnt + 2);
4999 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5001 *bp++ = i; /* store character from PerlIO_getc */
5003 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5004 goto thats_all_folks;
5008 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5009 memNE((char*)bp - rslen, rsptr, rslen))
5010 goto screamer; /* go back to the fray */
5011 thats_really_all_folks:
5013 cnt += shortbuffered;
5014 DEBUG_P(PerlIO_printf(Perl_debug_log,
5015 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5016 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5017 DEBUG_P(PerlIO_printf(Perl_debug_log,
5018 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5019 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5020 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5022 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5023 DEBUG_P(PerlIO_printf(Perl_debug_log,
5024 "Screamer: done, len=%ld, string=|%.*s|\n",
5025 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5030 /*The big, slow, and stupid way */
5033 /* Need to work around EPOC SDK features */
5034 /* On WINS: MS VC5 generates calls to _chkstk, */
5035 /* if a `large' stack frame is allocated */
5036 /* gcc on MARM does not generate calls like these */
5042 register STDCHAR *bpe = buf + sizeof(buf);
5044 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5045 ; /* keep reading */
5049 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5050 /* Accomodate broken VAXC compiler, which applies U8 cast to
5051 * both args of ?: operator, causing EOF to change into 255
5053 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5057 sv_catpvn(sv, (char *) buf, cnt);
5059 sv_setpvn(sv, (char *) buf, cnt);
5061 if (i != EOF && /* joy */
5063 SvCUR(sv) < rslen ||
5064 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5068 * If we're reading from a TTY and we get a short read,
5069 * indicating that the user hit his EOF character, we need
5070 * to notice it now, because if we try to read from the TTY
5071 * again, the EOF condition will disappear.
5073 * The comparison of cnt to sizeof(buf) is an optimization
5074 * that prevents unnecessary calls to feof().
5078 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5083 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5084 while (i != EOF) { /* to make sure file boundaries work right */
5085 i = PerlIO_getc(fp);
5087 PerlIO_ungetc(fp,i);
5093 if (PerlIO_isutf8(fp))
5098 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5105 Auto-increment of the value in the SV.
5111 Perl_sv_inc(pTHX_ register SV *sv)
5120 if (SvTHINKFIRST(sv)) {
5121 if (SvREADONLY(sv)) {
5122 if (PL_curcop != &PL_compiling)
5123 Perl_croak(aTHX_ PL_no_modify);
5127 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5129 i = PTR2IV(SvRV(sv));
5134 flags = SvFLAGS(sv);
5135 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5136 /* It's (privately or publicly) a float, but not tested as an
5137 integer, so test it to see. */
5139 flags = SvFLAGS(sv);
5141 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5142 /* It's publicly an integer, or privately an integer-not-float */
5145 if (SvUVX(sv) == UV_MAX)
5146 sv_setnv(sv, (NV)UV_MAX + 1.0);
5148 (void)SvIOK_only_UV(sv);
5151 if (SvIVX(sv) == IV_MAX)
5152 sv_setuv(sv, (UV)IV_MAX + 1);
5154 (void)SvIOK_only(sv);
5160 if (flags & SVp_NOK) {
5161 (void)SvNOK_only(sv);
5166 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5167 if ((flags & SVTYPEMASK) < SVt_PVIV)
5168 sv_upgrade(sv, SVt_IV);
5169 (void)SvIOK_only(sv);
5174 while (isALPHA(*d)) d++;
5175 while (isDIGIT(*d)) d++;
5177 #ifdef PERL_PRESERVE_IVUV
5178 /* Got to punt this an an integer if needs be, but we don't issue
5179 warnings. Probably ought to make the sv_iv_please() that does
5180 the conversion if possible, and silently. */
5181 I32 numtype = looks_like_number(sv);
5182 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5183 /* Need to try really hard to see if it's an integer.
5184 9.22337203685478e+18 is an integer.
5185 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5186 so $a="9.22337203685478e+18"; $a+0; $a++
5187 needs to be the same as $a="9.22337203685478e+18"; $a++
5194 /* sv_2iv *should* have made this an NV */
5195 if (flags & SVp_NOK) {
5196 (void)SvNOK_only(sv);
5200 /* I don't think we can get here. Maybe I should assert this
5201 And if we do get here I suspect that sv_setnv will croak. NWC
5203 #if defined(USE_LONG_DOUBLE)
5204 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",
5205 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5207 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5208 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5211 #endif /* PERL_PRESERVE_IVUV */
5212 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5216 while (d >= SvPVX(sv)) {
5224 /* MKS: The original code here died if letters weren't consecutive.
5225 * at least it didn't have to worry about non-C locales. The
5226 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5227 * arranged in order (although not consecutively) and that only
5228 * [A-Za-z] are accepted by isALPHA in the C locale.
5230 if (*d != 'z' && *d != 'Z') {
5231 do { ++*d; } while (!isALPHA(*d));
5234 *(d--) -= 'z' - 'a';
5239 *(d--) -= 'z' - 'a' + 1;
5243 /* oh,oh, the number grew */
5244 SvGROW(sv, SvCUR(sv) + 2);
5246 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5257 Auto-decrement of the value in the SV.
5263 Perl_sv_dec(pTHX_ register SV *sv)
5271 if (SvTHINKFIRST(sv)) {
5272 if (SvREADONLY(sv)) {
5273 if (PL_curcop != &PL_compiling)
5274 Perl_croak(aTHX_ PL_no_modify);
5278 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5280 i = PTR2IV(SvRV(sv));
5285 /* Unlike sv_inc we don't have to worry about string-never-numbers
5286 and keeping them magic. But we mustn't warn on punting */
5287 flags = SvFLAGS(sv);
5288 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5289 /* It's publicly an integer, or privately an integer-not-float */
5292 if (SvUVX(sv) == 0) {
5293 (void)SvIOK_only(sv);
5297 (void)SvIOK_only_UV(sv);
5301 if (SvIVX(sv) == IV_MIN)
5302 sv_setnv(sv, (NV)IV_MIN - 1.0);
5304 (void)SvIOK_only(sv);
5310 if (flags & SVp_NOK) {
5312 (void)SvNOK_only(sv);
5315 if (!(flags & SVp_POK)) {
5316 if ((flags & SVTYPEMASK) < SVt_PVNV)
5317 sv_upgrade(sv, SVt_NV);
5319 (void)SvNOK_only(sv);
5322 #ifdef PERL_PRESERVE_IVUV
5324 I32 numtype = looks_like_number(sv);
5325 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5326 /* Need to try really hard to see if it's an integer.
5327 9.22337203685478e+18 is an integer.
5328 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5329 so $a="9.22337203685478e+18"; $a+0; $a--
5330 needs to be the same as $a="9.22337203685478e+18"; $a--
5337 /* sv_2iv *should* have made this an NV */
5338 if (flags & SVp_NOK) {
5339 (void)SvNOK_only(sv);
5343 /* I don't think we can get here. Maybe I should assert this
5344 And if we do get here I suspect that sv_setnv will croak. NWC
5346 #if defined(USE_LONG_DOUBLE)
5347 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",
5348 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5350 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5351 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5355 #endif /* PERL_PRESERVE_IVUV */
5356 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5360 =for apidoc sv_mortalcopy
5362 Creates a new SV which is a copy of the original SV. The new SV is marked
5368 /* Make a string that will exist for the duration of the expression
5369 * evaluation. Actually, it may have to last longer than that, but
5370 * hopefully we won't free it until it has been assigned to a
5371 * permanent location. */
5374 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5379 sv_setsv(sv,oldstr);
5381 PL_tmps_stack[++PL_tmps_ix] = sv;
5387 =for apidoc sv_newmortal
5389 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5395 Perl_sv_newmortal(pTHX)
5400 SvFLAGS(sv) = SVs_TEMP;
5402 PL_tmps_stack[++PL_tmps_ix] = sv;
5407 =for apidoc sv_2mortal
5409 Marks an SV as mortal. The SV will be destroyed when the current context
5415 /* same thing without the copying */
5418 Perl_sv_2mortal(pTHX_ register SV *sv)
5422 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5425 PL_tmps_stack[++PL_tmps_ix] = sv;
5433 Creates a new SV and copies a string into it. The reference count for the
5434 SV is set to 1. If C<len> is zero, Perl will compute the length using
5435 strlen(). For efficiency, consider using C<newSVpvn> instead.
5441 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5448 sv_setpvn(sv,s,len);
5453 =for apidoc newSVpvn
5455 Creates a new SV and copies a string into it. The reference count for the
5456 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5457 string. You are responsible for ensuring that the source string is at least
5464 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5469 sv_setpvn(sv,s,len);
5474 =for apidoc newSVpvn_share
5476 Creates a new SV and populates it with a string from
5477 the string table. Turns on READONLY and FAKE.
5478 The idea here is that as string table is used for shared hash
5479 keys these strings will have SvPVX == HeKEY and hash lookup
5480 will avoid string compare.
5486 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5489 bool is_utf8 = FALSE;
5495 PERL_HASH(hash, src, len);
5497 sv_upgrade(sv, SVt_PVIV);
5498 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5510 #if defined(PERL_IMPLICIT_CONTEXT)
5512 Perl_newSVpvf_nocontext(const char* pat, ...)
5517 va_start(args, pat);
5518 sv = vnewSVpvf(pat, &args);
5525 =for apidoc newSVpvf
5527 Creates a new SV an initialize it with the string formatted like
5534 Perl_newSVpvf(pTHX_ const char* pat, ...)
5538 va_start(args, pat);
5539 sv = vnewSVpvf(pat, &args);
5545 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5549 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5556 Creates a new SV and copies a floating point value into it.
5557 The reference count for the SV is set to 1.
5563 Perl_newSVnv(pTHX_ NV n)
5575 Creates a new SV and copies an integer into it. The reference count for the
5582 Perl_newSViv(pTHX_ IV i)
5594 Creates a new SV and copies an unsigned integer into it.
5595 The reference count for the SV is set to 1.
5601 Perl_newSVuv(pTHX_ UV u)
5611 =for apidoc newRV_noinc
5613 Creates an RV wrapper for an SV. The reference count for the original
5614 SV is B<not> incremented.
5620 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5625 sv_upgrade(sv, SVt_RV);
5632 /* newRV_inc is #defined to newRV in sv.h */
5634 Perl_newRV(pTHX_ SV *tmpRef)
5636 return newRV_noinc(SvREFCNT_inc(tmpRef));
5642 Creates a new SV which is an exact duplicate of the original SV.
5647 /* make an exact duplicate of old */
5650 Perl_newSVsv(pTHX_ register SV *old)
5656 if (SvTYPE(old) == SVTYPEMASK) {
5657 if (ckWARN_d(WARN_INTERNAL))
5658 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5673 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5681 char todo[PERL_UCHAR_MAX+1];
5686 if (!*s) { /* reset ?? searches */
5687 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5688 pm->op_pmdynflags &= ~PMdf_USED;
5693 /* reset variables */
5695 if (!HvARRAY(stash))
5698 Zero(todo, 256, char);
5700 i = (unsigned char)*s;
5704 max = (unsigned char)*s++;
5705 for ( ; i <= max; i++) {
5708 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5709 for (entry = HvARRAY(stash)[i];
5711 entry = HeNEXT(entry))
5713 if (!todo[(U8)*HeKEY(entry)])
5715 gv = (GV*)HeVAL(entry);
5717 if (SvTHINKFIRST(sv)) {
5718 if (!SvREADONLY(sv) && SvROK(sv))
5723 if (SvTYPE(sv) >= SVt_PV) {
5725 if (SvPVX(sv) != Nullch)
5732 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5734 #ifdef USE_ENVIRON_ARRAY
5736 environ[0] = Nullch;
5745 Perl_sv_2io(pTHX_ SV *sv)
5751 switch (SvTYPE(sv)) {
5759 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5763 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5765 return sv_2io(SvRV(sv));
5766 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5772 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5779 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5786 return *gvp = Nullgv, Nullcv;
5787 switch (SvTYPE(sv)) {
5806 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5807 tryAMAGICunDEREF(to_cv);
5810 if (SvTYPE(sv) == SVt_PVCV) {
5819 Perl_croak(aTHX_ "Not a subroutine reference");
5824 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5830 if (lref && !GvCVu(gv)) {
5833 tmpsv = NEWSV(704,0);
5834 gv_efullname3(tmpsv, gv, Nullch);
5835 /* XXX this is probably not what they think they're getting.
5836 * It has the same effect as "sub name;", i.e. just a forward
5838 newSUB(start_subparse(FALSE, 0),
5839 newSVOP(OP_CONST, 0, tmpsv),
5844 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5853 Returns true if the SV has a true value by Perl's rules.
5859 Perl_sv_true(pTHX_ register SV *sv)
5865 if ((tXpv = (XPV*)SvANY(sv)) &&
5866 (tXpv->xpv_cur > 1 ||
5867 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5874 return SvIVX(sv) != 0;
5877 return SvNVX(sv) != 0.0;
5879 return sv_2bool(sv);
5885 Perl_sv_iv(pTHX_ register SV *sv)
5889 return (IV)SvUVX(sv);
5896 Perl_sv_uv(pTHX_ register SV *sv)
5901 return (UV)SvIVX(sv);
5907 Perl_sv_nv(pTHX_ register SV *sv)
5915 Perl_sv_pv(pTHX_ SV *sv)
5922 return sv_2pv(sv, &n_a);
5926 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5932 return sv_2pv(sv, lp);
5936 =for apidoc sv_pvn_force
5938 Get a sensible string out of the SV somehow.
5944 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
5948 if (SvTHINKFIRST(sv) && !SvROK(sv))
5949 sv_force_normal(sv);
5955 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
5956 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
5957 PL_op_name[PL_op->op_type]);
5961 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
5966 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
5967 SvGROW(sv, len + 1);
5968 Move(s,SvPVX(sv),len,char);
5973 SvPOK_on(sv); /* validate pointer */
5975 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
5976 PTR2UV(sv),SvPVX(sv)));
5983 Perl_sv_pvbyte(pTHX_ SV *sv)
5989 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
5991 return sv_pvn(sv,lp);
5995 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
5997 return sv_pvn_force(sv,lp);
6001 Perl_sv_pvutf8(pTHX_ SV *sv)
6003 sv_utf8_upgrade(sv);
6008 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6010 sv_utf8_upgrade(sv);
6011 return sv_pvn(sv,lp);
6015 =for apidoc sv_pvutf8n_force
6017 Get a sensible UTF8-encoded string out of the SV somehow. See
6024 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6026 sv_utf8_upgrade(sv);
6027 return sv_pvn_force(sv,lp);
6031 =for apidoc sv_reftype
6033 Returns a string describing what the SV is a reference to.
6039 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6041 if (ob && SvOBJECT(sv))
6042 return HvNAME(SvSTASH(sv));
6044 switch (SvTYPE(sv)) {
6058 case SVt_PVLV: return "LVALUE";
6059 case SVt_PVAV: return "ARRAY";
6060 case SVt_PVHV: return "HASH";
6061 case SVt_PVCV: return "CODE";
6062 case SVt_PVGV: return "GLOB";
6063 case SVt_PVFM: return "FORMAT";
6064 case SVt_PVIO: return "IO";
6065 default: return "UNKNOWN";
6071 =for apidoc sv_isobject
6073 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6074 object. If the SV is not an RV, or if the object is not blessed, then this
6081 Perl_sv_isobject(pTHX_ SV *sv)
6098 Returns a boolean indicating whether the SV is blessed into the specified
6099 class. This does not check for subtypes; use C<sv_derived_from> to verify
6100 an inheritance relationship.
6106 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6118 return strEQ(HvNAME(SvSTASH(sv)), name);
6124 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6125 it will be upgraded to one. If C<classname> is non-null then the new SV will
6126 be blessed in the specified package. The new SV is returned and its
6127 reference count is 1.
6133 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6139 SV_CHECK_THINKFIRST(rv);
6142 if (SvTYPE(rv) >= SVt_PVMG) {
6143 U32 refcnt = SvREFCNT(rv);
6147 SvREFCNT(rv) = refcnt;
6150 if (SvTYPE(rv) < SVt_RV)
6151 sv_upgrade(rv, SVt_RV);
6152 else if (SvTYPE(rv) > SVt_RV) {
6153 (void)SvOOK_off(rv);
6154 if (SvPVX(rv) && SvLEN(rv))
6155 Safefree(SvPVX(rv));
6165 HV* stash = gv_stashpv(classname, TRUE);
6166 (void)sv_bless(rv, stash);
6172 =for apidoc sv_setref_pv
6174 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6175 argument will be upgraded to an RV. That RV will be modified to point to
6176 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6177 into the SV. The C<classname> argument indicates the package for the
6178 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6179 will be returned and will have a reference count of 1.
6181 Do not use with other Perl types such as HV, AV, SV, CV, because those
6182 objects will become corrupted by the pointer copy process.
6184 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6190 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6193 sv_setsv(rv, &PL_sv_undef);
6197 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6202 =for apidoc sv_setref_iv
6204 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6205 argument will be upgraded to an RV. That RV will be modified to point to
6206 the new SV. The C<classname> argument indicates the package for the
6207 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6208 will be returned and will have a reference count of 1.
6214 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6216 sv_setiv(newSVrv(rv,classname), iv);
6221 =for apidoc sv_setref_nv
6223 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6224 argument will be upgraded to an RV. That RV will be modified to point to
6225 the new SV. The C<classname> argument indicates the package for the
6226 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6227 will be returned and will have a reference count of 1.
6233 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6235 sv_setnv(newSVrv(rv,classname), nv);
6240 =for apidoc sv_setref_pvn
6242 Copies a string into a new SV, optionally blessing the SV. The length of the
6243 string must be specified with C<n>. The C<rv> argument will be upgraded to
6244 an RV. That RV will be modified to point to the new SV. The C<classname>
6245 argument indicates the package for the blessing. Set C<classname> to
6246 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6247 a reference count of 1.
6249 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6255 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6257 sv_setpvn(newSVrv(rv,classname), pv, n);
6262 =for apidoc sv_bless
6264 Blesses an SV into a specified package. The SV must be an RV. The package
6265 must be designated by its stash (see C<gv_stashpv()>). The reference count
6266 of the SV is unaffected.
6272 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6276 Perl_croak(aTHX_ "Can't bless non-reference value");
6278 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6279 if (SvREADONLY(tmpRef))
6280 Perl_croak(aTHX_ PL_no_modify);
6281 if (SvOBJECT(tmpRef)) {
6282 if (SvTYPE(tmpRef) != SVt_PVIO)
6284 SvREFCNT_dec(SvSTASH(tmpRef));
6287 SvOBJECT_on(tmpRef);
6288 if (SvTYPE(tmpRef) != SVt_PVIO)
6290 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6291 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6302 S_sv_unglob(pTHX_ SV *sv)
6306 assert(SvTYPE(sv) == SVt_PVGV);
6311 SvREFCNT_dec(GvSTASH(sv));
6312 GvSTASH(sv) = Nullhv;
6314 sv_unmagic(sv, '*');
6315 Safefree(GvNAME(sv));
6318 /* need to keep SvANY(sv) in the right arena */
6319 xpvmg = new_XPVMG();
6320 StructCopy(SvANY(sv), xpvmg, XPVMG);
6321 del_XPVGV(SvANY(sv));
6324 SvFLAGS(sv) &= ~SVTYPEMASK;
6325 SvFLAGS(sv) |= SVt_PVMG;
6329 =for apidoc sv_unref_flags
6331 Unsets the RV status of the SV, and decrements the reference count of
6332 whatever was being referenced by the RV. This can almost be thought of
6333 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6334 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6335 (otherwise the decrementing is conditional on the reference count being
6336 different from one or the reference being a readonly SV).
6343 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6347 if (SvWEAKREF(sv)) {
6355 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6357 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6358 sv_2mortal(rv); /* Schedule for freeing later */
6362 =for apidoc sv_unref
6364 Unsets the RV status of the SV, and decrements the reference count of
6365 whatever was being referenced by the RV. This can almost be thought of
6366 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6367 being zero. See C<SvROK_off>.
6373 Perl_sv_unref(pTHX_ SV *sv)
6375 sv_unref_flags(sv, 0);
6379 Perl_sv_taint(pTHX_ SV *sv)
6381 sv_magic((sv), Nullsv, 't', Nullch, 0);
6385 Perl_sv_untaint(pTHX_ SV *sv)
6387 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6388 MAGIC *mg = mg_find(sv, 't');
6395 Perl_sv_tainted(pTHX_ SV *sv)
6397 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6398 MAGIC *mg = mg_find(sv, 't');
6399 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6406 =for apidoc sv_setpviv
6408 Copies an integer into the given SV, also updating its string value.
6409 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6415 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6417 char buf[TYPE_CHARS(UV)];
6419 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6421 sv_setpvn(sv, ptr, ebuf - ptr);
6426 =for apidoc sv_setpviv_mg
6428 Like C<sv_setpviv>, but also handles 'set' magic.
6434 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6436 char buf[TYPE_CHARS(UV)];
6438 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6440 sv_setpvn(sv, ptr, ebuf - ptr);
6444 #if defined(PERL_IMPLICIT_CONTEXT)
6446 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6450 va_start(args, pat);
6451 sv_vsetpvf(sv, pat, &args);
6457 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6461 va_start(args, pat);
6462 sv_vsetpvf_mg(sv, pat, &args);
6468 =for apidoc sv_setpvf
6470 Processes its arguments like C<sprintf> and sets an SV to the formatted
6471 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6477 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6480 va_start(args, pat);
6481 sv_vsetpvf(sv, pat, &args);
6486 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6488 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6492 =for apidoc sv_setpvf_mg
6494 Like C<sv_setpvf>, but also handles 'set' magic.
6500 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6503 va_start(args, pat);
6504 sv_vsetpvf_mg(sv, pat, &args);
6509 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6511 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6515 #if defined(PERL_IMPLICIT_CONTEXT)
6517 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6521 va_start(args, pat);
6522 sv_vcatpvf(sv, pat, &args);
6527 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6531 va_start(args, pat);
6532 sv_vcatpvf_mg(sv, pat, &args);
6538 =for apidoc sv_catpvf
6540 Processes its arguments like C<sprintf> and appends the formatted output
6541 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6542 typically be called after calling this function to handle 'set' magic.
6548 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6551 va_start(args, pat);
6552 sv_vcatpvf(sv, pat, &args);
6557 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6559 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6563 =for apidoc sv_catpvf_mg
6565 Like C<sv_catpvf>, but also handles 'set' magic.
6571 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6574 va_start(args, pat);
6575 sv_vcatpvf_mg(sv, pat, &args);
6580 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6582 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6587 =for apidoc sv_vsetpvfn
6589 Works like C<vcatpvfn> but copies the text into the SV instead of
6596 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6598 sv_setpvn(sv, "", 0);
6599 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6603 =for apidoc sv_vcatpvfn
6605 Processes its arguments like C<vsprintf> and appends the formatted output
6606 to an SV. Uses an array of SVs if the C style variable argument list is
6607 missing (NULL). When running with taint checks enabled, indicates via
6608 C<maybe_tainted> if results are untrustworthy (often due to the use of
6615 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6622 static char nullstr[] = "(null)";
6625 /* no matter what, this is a string now */
6626 (void)SvPV_force(sv, origlen);
6628 /* special-case "", "%s", and "%_" */
6631 if (patlen == 2 && pat[0] == '%') {
6635 char *s = va_arg(*args, char*);
6636 sv_catpv(sv, s ? s : nullstr);
6638 else if (svix < svmax) {
6639 sv_catsv(sv, *svargs);
6640 if (DO_UTF8(*svargs))
6646 argsv = va_arg(*args, SV*);
6647 sv_catsv(sv, argsv);
6652 /* See comment on '_' below */
6657 patend = (char*)pat + patlen;
6658 for (p = (char*)pat; p < patend; p = q) {
6661 bool vectorize = FALSE;
6668 bool has_precis = FALSE;
6670 bool is_utf = FALSE;
6673 U8 utf8buf[UTF8_MAXLEN+1];
6674 STRLEN esignlen = 0;
6676 char *eptr = Nullch;
6678 /* Times 4: a decimal digit takes more than 3 binary digits.
6679 * NV_DIG: mantissa takes than many decimal digits.
6680 * Plus 32: Playing safe. */
6681 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6682 /* large enough for "%#.#f" --chip */
6683 /* what about long double NVs? --jhi */
6686 U8 *vecstr = Null(U8*);
6698 STRLEN dotstrlen = 1;
6699 I32 epix = 0; /* explicit parameter index */
6700 I32 ewix = 0; /* explicit width index */
6701 bool asterisk = FALSE;
6703 for (q = p; q < patend && *q != '%'; ++q) ;
6705 sv_catpvn(sv, p, q - p);
6734 case '*': /* printf("%*vX",":",$ipv6addr) */
6739 vecsv = va_arg(*args, SV*);
6740 else if (svix < svmax)
6741 vecsv = svargs[svix++];
6744 dotstr = SvPVx(vecsv,dotstrlen);
6772 case '1': case '2': case '3':
6773 case '4': case '5': case '6':
6774 case '7': case '8': case '9':
6777 width = width * 10 + (*q++ - '0');
6779 if (asterisk && ewix == 0) {
6784 } else if (epix == 0) {
6796 i = va_arg(*args, int);
6798 i = (ewix ? ewix <= svmax : svix < svmax) ?
6799 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6801 width = (i < 0) ? -i : i;
6810 i = va_arg(*args, int);
6812 i = (ewix ? ewix <= svmax : svix < svmax)
6813 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6814 precis = (i < 0) ? 0 : i;
6820 precis = precis * 10 + (*q++ - '0');
6827 vecsv = va_arg(*args, SV*);
6828 vecstr = (U8*)SvPVx(vecsv,veclen);
6829 utf = DO_UTF8(vecsv);
6831 else if (epix ? epix <= svmax : svix < svmax) {
6832 vecsv = svargs[epix ? epix-1 : svix++];
6833 vecstr = (U8*)SvPVx(vecsv,veclen);
6834 utf = DO_UTF8(vecsv);
6845 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6856 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6857 if (*(q + 1) == 'l') { /* lld, llf */
6884 uv = va_arg(*args, int);
6886 uv = (epix ? epix <= svmax : svix < svmax) ?
6887 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6888 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6889 eptr = (char*)utf8buf;
6890 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6902 eptr = va_arg(*args, char*);
6904 #ifdef MACOS_TRADITIONAL
6905 /* On MacOS, %#s format is used for Pascal strings */
6910 elen = strlen(eptr);
6913 elen = sizeof nullstr - 1;
6916 else if (epix ? epix <= svmax : svix < svmax) {
6917 argsv = svargs[epix ? epix-1 : svix++];
6918 eptr = SvPVx(argsv, elen);
6919 if (DO_UTF8(argsv)) {
6920 if (has_precis && precis < elen) {
6922 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6925 if (width) { /* fudge width (can't fudge elen) */
6926 width += elen - sv_len_utf8(argsv);
6935 * The "%_" hack might have to be changed someday,
6936 * if ISO or ANSI decide to use '_' for something.
6937 * So we keep it hidden from users' code.
6941 argsv = va_arg(*args,SV*);
6942 eptr = SvPVx(argsv, elen);
6948 if (has_precis && elen > precis)
6958 uv = PTR2UV(va_arg(*args, void*));
6960 uv = (epix ? epix <= svmax : svix < svmax) ?
6961 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
6981 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
6991 case 'h': iv = (short)va_arg(*args, int); break;
6992 default: iv = va_arg(*args, int); break;
6993 case 'l': iv = va_arg(*args, long); break;
6994 case 'V': iv = va_arg(*args, IV); break;
6996 case 'q': iv = va_arg(*args, Quad_t); break;
7001 iv = (epix ? epix <= svmax : svix < svmax) ?
7002 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
7004 case 'h': iv = (short)iv; break;
7006 case 'l': iv = (long)iv; break;
7009 case 'q': iv = (Quad_t)iv; break;
7016 esignbuf[esignlen++] = plus;
7020 esignbuf[esignlen++] = '-';
7064 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7074 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7075 default: uv = va_arg(*args, unsigned); break;
7076 case 'l': uv = va_arg(*args, unsigned long); break;
7077 case 'V': uv = va_arg(*args, UV); break;
7079 case 'q': uv = va_arg(*args, Quad_t); break;
7084 uv = (epix ? epix <= svmax : svix < svmax) ?
7085 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
7087 case 'h': uv = (unsigned short)uv; break;
7089 case 'l': uv = (unsigned long)uv; break;
7092 case 'q': uv = (Quad_t)uv; break;
7098 eptr = ebuf + sizeof ebuf;
7104 p = (char*)((c == 'X')
7105 ? "0123456789ABCDEF" : "0123456789abcdef");
7111 esignbuf[esignlen++] = '0';
7112 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7118 *--eptr = '0' + dig;
7120 if (alt && *eptr != '0')
7126 *--eptr = '0' + dig;
7129 esignbuf[esignlen++] = '0';
7130 esignbuf[esignlen++] = 'b';
7133 default: /* it had better be ten or less */
7134 #if defined(PERL_Y2KWARN)
7135 if (ckWARN(WARN_Y2K)) {
7137 char *s = SvPV(sv,n);
7138 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7139 && (n == 2 || !isDIGIT(s[n-3])))
7141 Perl_warner(aTHX_ WARN_Y2K,
7142 "Possible Y2K bug: %%%c %s",
7143 c, "format string following '19'");
7149 *--eptr = '0' + dig;
7150 } while (uv /= base);
7153 elen = (ebuf + sizeof ebuf) - eptr;
7156 zeros = precis - elen;
7157 else if (precis == 0 && elen == 1 && *eptr == '0')
7162 /* FLOATING POINT */
7165 c = 'f'; /* maybe %F isn't supported here */
7171 /* This is evil, but floating point is even more evil */
7175 nv = va_arg(*args, NV);
7177 nv = (epix ? epix <= svmax : svix < svmax) ?
7178 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
7181 if (c != 'e' && c != 'E') {
7183 (void)Perl_frexp(nv, &i);
7184 if (i == PERL_INT_MIN)
7185 Perl_die(aTHX_ "panic: frexp");
7187 need = BIT_DIGITS(i);
7189 need += has_precis ? precis : 6; /* known default */
7193 need += 20; /* fudge factor */
7194 if (PL_efloatsize < need) {
7195 Safefree(PL_efloatbuf);
7196 PL_efloatsize = need + 20; /* more fudge */
7197 New(906, PL_efloatbuf, PL_efloatsize, char);
7198 PL_efloatbuf[0] = '\0';
7201 eptr = ebuf + sizeof ebuf;
7204 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7206 /* Copy the one or more characters in a long double
7207 * format before the 'base' ([efgEFG]) character to
7208 * the format string. */
7209 static char const prifldbl[] = PERL_PRIfldbl;
7210 char const *p = prifldbl + sizeof(prifldbl) - 3;
7211 while (p >= prifldbl) { *--eptr = *p--; }
7216 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7221 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7233 /* No taint. Otherwise we are in the strange situation
7234 * where printf() taints but print($float) doesn't.
7236 (void)sprintf(PL_efloatbuf, eptr, nv);
7238 eptr = PL_efloatbuf;
7239 elen = strlen(PL_efloatbuf);
7246 i = SvCUR(sv) - origlen;
7249 case 'h': *(va_arg(*args, short*)) = i; break;
7250 default: *(va_arg(*args, int*)) = i; break;
7251 case 'l': *(va_arg(*args, long*)) = i; break;
7252 case 'V': *(va_arg(*args, IV*)) = i; break;
7254 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7258 else if (epix ? epix <= svmax : svix < svmax)
7259 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
7260 continue; /* not "break" */
7267 if (!args && ckWARN(WARN_PRINTF) &&
7268 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7269 SV *msg = sv_newmortal();
7270 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7271 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7274 Perl_sv_catpvf(aTHX_ msg,
7275 "\"%%%c\"", c & 0xFF);
7277 Perl_sv_catpvf(aTHX_ msg,
7278 "\"%%\\%03"UVof"\"",
7281 sv_catpv(msg, "end of string");
7282 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7285 /* output mangled stuff ... */
7291 /* ... right here, because formatting flags should not apply */
7292 SvGROW(sv, SvCUR(sv) + elen + 1);
7294 memcpy(p, eptr, elen);
7297 SvCUR(sv) = p - SvPVX(sv);
7298 continue; /* not "break" */
7301 have = esignlen + zeros + elen;
7302 need = (have > width ? have : width);
7305 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7307 if (esignlen && fill == '0') {
7308 for (i = 0; i < esignlen; i++)
7312 memset(p, fill, gap);
7315 if (esignlen && fill != '0') {
7316 for (i = 0; i < esignlen; i++)
7320 for (i = zeros; i; i--)
7324 memcpy(p, eptr, elen);
7328 memset(p, ' ', gap);
7333 memcpy(p, dotstr, dotstrlen);
7337 vectorize = FALSE; /* done iterating over vecstr */
7342 SvCUR(sv) = p - SvPVX(sv);
7350 #if defined(USE_ITHREADS)
7352 #if defined(USE_THREADS)
7353 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7356 #ifndef GpREFCNT_inc
7357 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7361 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7362 #define av_dup(s) (AV*)sv_dup((SV*)s)
7363 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7364 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7365 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7366 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7367 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7368 #define io_dup(s) (IO*)sv_dup((SV*)s)
7369 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7370 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7371 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7372 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7373 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7376 Perl_re_dup(pTHX_ REGEXP *r)
7378 /* XXX fix when pmop->op_pmregexp becomes shared */
7379 return ReREFCNT_inc(r);
7383 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7387 return (PerlIO*)NULL;
7389 /* look for it in the table first */
7390 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7394 /* create anew and remember what it is */
7395 ret = PerlIO_fdupopen(aTHX_ fp);
7396 ptr_table_store(PL_ptr_table, fp, ret);
7401 Perl_dirp_dup(pTHX_ DIR *dp)
7410 Perl_gp_dup(pTHX_ GP *gp)
7415 /* look for it in the table first */
7416 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7420 /* create anew and remember what it is */
7421 Newz(0, ret, 1, GP);
7422 ptr_table_store(PL_ptr_table, gp, ret);
7425 ret->gp_refcnt = 0; /* must be before any other dups! */
7426 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7427 ret->gp_io = io_dup_inc(gp->gp_io);
7428 ret->gp_form = cv_dup_inc(gp->gp_form);
7429 ret->gp_av = av_dup_inc(gp->gp_av);
7430 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7431 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7432 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7433 ret->gp_cvgen = gp->gp_cvgen;
7434 ret->gp_flags = gp->gp_flags;
7435 ret->gp_line = gp->gp_line;
7436 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7441 Perl_mg_dup(pTHX_ MAGIC *mg)
7443 MAGIC *mgret = (MAGIC*)NULL;
7446 return (MAGIC*)NULL;
7447 /* look for it in the table first */
7448 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7452 for (; mg; mg = mg->mg_moremagic) {
7454 Newz(0, nmg, 1, MAGIC);
7458 mgprev->mg_moremagic = nmg;
7459 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7460 nmg->mg_private = mg->mg_private;
7461 nmg->mg_type = mg->mg_type;
7462 nmg->mg_flags = mg->mg_flags;
7463 if (mg->mg_type == 'r') {
7464 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7467 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7468 ? sv_dup_inc(mg->mg_obj)
7469 : sv_dup(mg->mg_obj);
7471 nmg->mg_len = mg->mg_len;
7472 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7473 if (mg->mg_ptr && mg->mg_type != 'g') {
7474 if (mg->mg_len >= 0) {
7475 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7476 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7477 AMT *amtp = (AMT*)mg->mg_ptr;
7478 AMT *namtp = (AMT*)nmg->mg_ptr;
7480 for (i = 1; i < NofAMmeth; i++) {
7481 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7485 else if (mg->mg_len == HEf_SVKEY)
7486 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7494 Perl_ptr_table_new(pTHX)
7497 Newz(0, tbl, 1, PTR_TBL_t);
7500 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7505 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7507 PTR_TBL_ENT_t *tblent;
7508 UV hash = PTR2UV(sv);
7510 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7511 for (; tblent; tblent = tblent->next) {
7512 if (tblent->oldval == sv)
7513 return tblent->newval;
7519 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7521 PTR_TBL_ENT_t *tblent, **otblent;
7522 /* XXX this may be pessimal on platforms where pointers aren't good
7523 * hash values e.g. if they grow faster in the most significant
7525 UV hash = PTR2UV(oldv);
7529 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7530 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7531 if (tblent->oldval == oldv) {
7532 tblent->newval = newv;
7537 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7538 tblent->oldval = oldv;
7539 tblent->newval = newv;
7540 tblent->next = *otblent;
7543 if (i && tbl->tbl_items > tbl->tbl_max)
7544 ptr_table_split(tbl);
7548 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7550 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7551 UV oldsize = tbl->tbl_max + 1;
7552 UV newsize = oldsize * 2;
7555 Renew(ary, newsize, PTR_TBL_ENT_t*);
7556 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7557 tbl->tbl_max = --newsize;
7559 for (i=0; i < oldsize; i++, ary++) {
7560 PTR_TBL_ENT_t **curentp, **entp, *ent;
7563 curentp = ary + oldsize;
7564 for (entp = ary, ent = *ary; ent; ent = *entp) {
7565 if ((newsize & PTR2UV(ent->oldval)) != i) {
7567 ent->next = *curentp;
7582 Perl_sv_dup(pTHX_ SV *sstr)
7586 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7588 /* look for it in the table first */
7589 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7593 /* create anew and remember what it is */
7595 ptr_table_store(PL_ptr_table, sstr, dstr);
7598 SvFLAGS(dstr) = SvFLAGS(sstr);
7599 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7600 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7603 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7604 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7605 PL_watch_pvx, SvPVX(sstr));
7608 switch (SvTYPE(sstr)) {
7613 SvANY(dstr) = new_XIV();
7614 SvIVX(dstr) = SvIVX(sstr);
7617 SvANY(dstr) = new_XNV();
7618 SvNVX(dstr) = SvNVX(sstr);
7621 SvANY(dstr) = new_XRV();
7622 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7625 SvANY(dstr) = new_XPV();
7626 SvCUR(dstr) = SvCUR(sstr);
7627 SvLEN(dstr) = SvLEN(sstr);
7629 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7630 else if (SvPVX(sstr) && SvLEN(sstr))
7631 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7633 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7636 SvANY(dstr) = new_XPVIV();
7637 SvCUR(dstr) = SvCUR(sstr);
7638 SvLEN(dstr) = SvLEN(sstr);
7639 SvIVX(dstr) = SvIVX(sstr);
7641 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7642 else if (SvPVX(sstr) && SvLEN(sstr))
7643 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7645 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7648 SvANY(dstr) = new_XPVNV();
7649 SvCUR(dstr) = SvCUR(sstr);
7650 SvLEN(dstr) = SvLEN(sstr);
7651 SvIVX(dstr) = SvIVX(sstr);
7652 SvNVX(dstr) = SvNVX(sstr);
7654 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7655 else if (SvPVX(sstr) && SvLEN(sstr))
7656 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7658 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7661 SvANY(dstr) = new_XPVMG();
7662 SvCUR(dstr) = SvCUR(sstr);
7663 SvLEN(dstr) = SvLEN(sstr);
7664 SvIVX(dstr) = SvIVX(sstr);
7665 SvNVX(dstr) = SvNVX(sstr);
7666 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7667 SvSTASH(dstr) = hv_dup_inc(SvSTASH(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_XPVBM();
7677 SvCUR(dstr) = SvCUR(sstr);
7678 SvLEN(dstr) = SvLEN(sstr);
7679 SvIVX(dstr) = SvIVX(sstr);
7680 SvNVX(dstr) = SvNVX(sstr);
7681 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7682 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7684 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7685 else if (SvPVX(sstr) && SvLEN(sstr))
7686 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7688 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7689 BmRARE(dstr) = BmRARE(sstr);
7690 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7691 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7694 SvANY(dstr) = new_XPVLV();
7695 SvCUR(dstr) = SvCUR(sstr);
7696 SvLEN(dstr) = SvLEN(sstr);
7697 SvIVX(dstr) = SvIVX(sstr);
7698 SvNVX(dstr) = SvNVX(sstr);
7699 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7700 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7702 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7703 else if (SvPVX(sstr) && SvLEN(sstr))
7704 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7706 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7707 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7708 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7709 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7710 LvTYPE(dstr) = LvTYPE(sstr);
7713 SvANY(dstr) = new_XPVGV();
7714 SvCUR(dstr) = SvCUR(sstr);
7715 SvLEN(dstr) = SvLEN(sstr);
7716 SvIVX(dstr) = SvIVX(sstr);
7717 SvNVX(dstr) = SvNVX(sstr);
7718 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7719 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7721 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7722 else if (SvPVX(sstr) && SvLEN(sstr))
7723 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7725 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7726 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7727 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7728 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7729 GvFLAGS(dstr) = GvFLAGS(sstr);
7730 GvGP(dstr) = gp_dup(GvGP(sstr));
7731 (void)GpREFCNT_inc(GvGP(dstr));
7734 SvANY(dstr) = new_XPVIO();
7735 SvCUR(dstr) = SvCUR(sstr);
7736 SvLEN(dstr) = SvLEN(sstr);
7737 SvIVX(dstr) = SvIVX(sstr);
7738 SvNVX(dstr) = SvNVX(sstr);
7739 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7740 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7742 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7743 else if (SvPVX(sstr) && SvLEN(sstr))
7744 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7746 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7747 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7748 if (IoOFP(sstr) == IoIFP(sstr))
7749 IoOFP(dstr) = IoIFP(dstr);
7751 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7752 /* PL_rsfp_filters entries have fake IoDIRP() */
7753 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7754 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7756 IoDIRP(dstr) = IoDIRP(sstr);
7757 IoLINES(dstr) = IoLINES(sstr);
7758 IoPAGE(dstr) = IoPAGE(sstr);
7759 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7760 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7761 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7762 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7763 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7764 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7765 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7766 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7767 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7768 IoTYPE(dstr) = IoTYPE(sstr);
7769 IoFLAGS(dstr) = IoFLAGS(sstr);
7772 SvANY(dstr) = new_XPVAV();
7773 SvCUR(dstr) = SvCUR(sstr);
7774 SvLEN(dstr) = SvLEN(sstr);
7775 SvIVX(dstr) = SvIVX(sstr);
7776 SvNVX(dstr) = SvNVX(sstr);
7777 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7778 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7779 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7780 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7781 if (AvARRAY((AV*)sstr)) {
7782 SV **dst_ary, **src_ary;
7783 SSize_t items = AvFILLp((AV*)sstr) + 1;
7785 src_ary = AvARRAY((AV*)sstr);
7786 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7787 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7788 SvPVX(dstr) = (char*)dst_ary;
7789 AvALLOC((AV*)dstr) = dst_ary;
7790 if (AvREAL((AV*)sstr)) {
7792 *dst_ary++ = sv_dup_inc(*src_ary++);
7796 *dst_ary++ = sv_dup(*src_ary++);
7798 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7799 while (items-- > 0) {
7800 *dst_ary++ = &PL_sv_undef;
7804 SvPVX(dstr) = Nullch;
7805 AvALLOC((AV*)dstr) = (SV**)NULL;
7809 SvANY(dstr) = new_XPVHV();
7810 SvCUR(dstr) = SvCUR(sstr);
7811 SvLEN(dstr) = SvLEN(sstr);
7812 SvIVX(dstr) = SvIVX(sstr);
7813 SvNVX(dstr) = SvNVX(sstr);
7814 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7815 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7816 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7817 if (HvARRAY((HV*)sstr)) {
7819 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7820 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7821 Newz(0, dxhv->xhv_array,
7822 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7823 while (i <= sxhv->xhv_max) {
7824 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7825 !!HvSHAREKEYS(sstr));
7828 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7831 SvPVX(dstr) = Nullch;
7832 HvEITER((HV*)dstr) = (HE*)NULL;
7834 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7835 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7838 SvANY(dstr) = new_XPVFM();
7839 FmLINES(dstr) = FmLINES(sstr);
7843 SvANY(dstr) = new_XPVCV();
7845 SvCUR(dstr) = SvCUR(sstr);
7846 SvLEN(dstr) = SvLEN(sstr);
7847 SvIVX(dstr) = SvIVX(sstr);
7848 SvNVX(dstr) = SvNVX(sstr);
7849 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7850 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7851 if (SvPVX(sstr) && SvLEN(sstr))
7852 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7854 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7855 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7856 CvSTART(dstr) = CvSTART(sstr);
7857 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7858 CvXSUB(dstr) = CvXSUB(sstr);
7859 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7860 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7861 CvDEPTH(dstr) = CvDEPTH(sstr);
7862 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7863 /* XXX padlists are real, but pretend to be not */
7864 AvREAL_on(CvPADLIST(sstr));
7865 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7866 AvREAL_off(CvPADLIST(sstr));
7867 AvREAL_off(CvPADLIST(dstr));
7870 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7871 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7872 CvFLAGS(dstr) = CvFLAGS(sstr);
7875 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7879 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7886 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7891 return (PERL_CONTEXT*)NULL;
7893 /* look for it in the table first */
7894 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7898 /* create anew and remember what it is */
7899 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7900 ptr_table_store(PL_ptr_table, cxs, ncxs);
7903 PERL_CONTEXT *cx = &cxs[ix];
7904 PERL_CONTEXT *ncx = &ncxs[ix];
7905 ncx->cx_type = cx->cx_type;
7906 if (CxTYPE(cx) == CXt_SUBST) {
7907 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7910 ncx->blk_oldsp = cx->blk_oldsp;
7911 ncx->blk_oldcop = cx->blk_oldcop;
7912 ncx->blk_oldretsp = cx->blk_oldretsp;
7913 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7914 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7915 ncx->blk_oldpm = cx->blk_oldpm;
7916 ncx->blk_gimme = cx->blk_gimme;
7917 switch (CxTYPE(cx)) {
7919 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7920 ? cv_dup_inc(cx->blk_sub.cv)
7921 : cv_dup(cx->blk_sub.cv));
7922 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7923 ? av_dup_inc(cx->blk_sub.argarray)
7925 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7926 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7927 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7928 ncx->blk_sub.lval = cx->blk_sub.lval;
7931 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7932 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7933 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7934 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7935 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7938 ncx->blk_loop.label = cx->blk_loop.label;
7939 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7940 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7941 ncx->blk_loop.next_op = cx->blk_loop.next_op;
7942 ncx->blk_loop.last_op = cx->blk_loop.last_op;
7943 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
7944 ? cx->blk_loop.iterdata
7945 : gv_dup((GV*)cx->blk_loop.iterdata));
7946 ncx->blk_loop.oldcurpad
7947 = (SV**)ptr_table_fetch(PL_ptr_table,
7948 cx->blk_loop.oldcurpad);
7949 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
7950 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
7951 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
7952 ncx->blk_loop.iterix = cx->blk_loop.iterix;
7953 ncx->blk_loop.itermax = cx->blk_loop.itermax;
7956 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
7957 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
7958 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
7959 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7972 Perl_si_dup(pTHX_ PERL_SI *si)
7977 return (PERL_SI*)NULL;
7979 /* look for it in the table first */
7980 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
7984 /* create anew and remember what it is */
7985 Newz(56, nsi, 1, PERL_SI);
7986 ptr_table_store(PL_ptr_table, si, nsi);
7988 nsi->si_stack = av_dup_inc(si->si_stack);
7989 nsi->si_cxix = si->si_cxix;
7990 nsi->si_cxmax = si->si_cxmax;
7991 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
7992 nsi->si_type = si->si_type;
7993 nsi->si_prev = si_dup(si->si_prev);
7994 nsi->si_next = si_dup(si->si_next);
7995 nsi->si_markoff = si->si_markoff;
8000 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8001 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8002 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8003 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8004 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8005 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8006 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8007 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8008 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8009 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8010 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8011 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8014 #define pv_dup_inc(p) SAVEPV(p)
8015 #define pv_dup(p) SAVEPV(p)
8016 #define svp_dup_inc(p,pp) any_dup(p,pp)
8019 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8026 /* look for it in the table first */
8027 ret = ptr_table_fetch(PL_ptr_table, v);
8031 /* see if it is part of the interpreter structure */
8032 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8033 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8041 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8043 ANY *ss = proto_perl->Tsavestack;
8044 I32 ix = proto_perl->Tsavestack_ix;
8045 I32 max = proto_perl->Tsavestack_max;
8058 void (*dptr) (void*);
8059 void (*dxptr) (pTHXo_ void*);
8062 Newz(54, nss, max, ANY);
8068 case SAVEt_ITEM: /* normal string */
8069 sv = (SV*)POPPTR(ss,ix);
8070 TOPPTR(nss,ix) = sv_dup_inc(sv);
8071 sv = (SV*)POPPTR(ss,ix);
8072 TOPPTR(nss,ix) = sv_dup_inc(sv);
8074 case SAVEt_SV: /* scalar reference */
8075 sv = (SV*)POPPTR(ss,ix);
8076 TOPPTR(nss,ix) = sv_dup_inc(sv);
8077 gv = (GV*)POPPTR(ss,ix);
8078 TOPPTR(nss,ix) = gv_dup_inc(gv);
8080 case SAVEt_GENERIC_PVREF: /* generic char* */
8081 c = (char*)POPPTR(ss,ix);
8082 TOPPTR(nss,ix) = pv_dup(c);
8083 ptr = POPPTR(ss,ix);
8084 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8086 case SAVEt_GENERIC_SVREF: /* generic sv */
8087 case SAVEt_SVREF: /* scalar reference */
8088 sv = (SV*)POPPTR(ss,ix);
8089 TOPPTR(nss,ix) = sv_dup_inc(sv);
8090 ptr = POPPTR(ss,ix);
8091 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8093 case SAVEt_AV: /* array reference */
8094 av = (AV*)POPPTR(ss,ix);
8095 TOPPTR(nss,ix) = av_dup_inc(av);
8096 gv = (GV*)POPPTR(ss,ix);
8097 TOPPTR(nss,ix) = gv_dup(gv);
8099 case SAVEt_HV: /* hash reference */
8100 hv = (HV*)POPPTR(ss,ix);
8101 TOPPTR(nss,ix) = hv_dup_inc(hv);
8102 gv = (GV*)POPPTR(ss,ix);
8103 TOPPTR(nss,ix) = gv_dup(gv);
8105 case SAVEt_INT: /* int reference */
8106 ptr = POPPTR(ss,ix);
8107 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8108 intval = (int)POPINT(ss,ix);
8109 TOPINT(nss,ix) = intval;
8111 case SAVEt_LONG: /* long reference */
8112 ptr = POPPTR(ss,ix);
8113 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8114 longval = (long)POPLONG(ss,ix);
8115 TOPLONG(nss,ix) = longval;
8117 case SAVEt_I32: /* I32 reference */
8118 case SAVEt_I16: /* I16 reference */
8119 case SAVEt_I8: /* I8 reference */
8120 ptr = POPPTR(ss,ix);
8121 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8125 case SAVEt_IV: /* IV reference */
8126 ptr = POPPTR(ss,ix);
8127 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8131 case SAVEt_SPTR: /* SV* reference */
8132 ptr = POPPTR(ss,ix);
8133 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8134 sv = (SV*)POPPTR(ss,ix);
8135 TOPPTR(nss,ix) = sv_dup(sv);
8137 case SAVEt_VPTR: /* random* reference */
8138 ptr = POPPTR(ss,ix);
8139 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8140 ptr = POPPTR(ss,ix);
8141 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8143 case SAVEt_PPTR: /* char* reference */
8144 ptr = POPPTR(ss,ix);
8145 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8146 c = (char*)POPPTR(ss,ix);
8147 TOPPTR(nss,ix) = pv_dup(c);
8149 case SAVEt_HPTR: /* HV* reference */
8150 ptr = POPPTR(ss,ix);
8151 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8152 hv = (HV*)POPPTR(ss,ix);
8153 TOPPTR(nss,ix) = hv_dup(hv);
8155 case SAVEt_APTR: /* AV* reference */
8156 ptr = POPPTR(ss,ix);
8157 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8158 av = (AV*)POPPTR(ss,ix);
8159 TOPPTR(nss,ix) = av_dup(av);
8162 gv = (GV*)POPPTR(ss,ix);
8163 TOPPTR(nss,ix) = gv_dup(gv);
8165 case SAVEt_GP: /* scalar reference */
8166 gp = (GP*)POPPTR(ss,ix);
8167 TOPPTR(nss,ix) = gp = gp_dup(gp);
8168 (void)GpREFCNT_inc(gp);
8169 gv = (GV*)POPPTR(ss,ix);
8170 TOPPTR(nss,ix) = gv_dup_inc(c);
8171 c = (char*)POPPTR(ss,ix);
8172 TOPPTR(nss,ix) = pv_dup(c);
8179 sv = (SV*)POPPTR(ss,ix);
8180 TOPPTR(nss,ix) = sv_dup_inc(sv);
8183 ptr = POPPTR(ss,ix);
8184 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8185 /* these are assumed to be refcounted properly */
8186 switch (((OP*)ptr)->op_type) {
8193 TOPPTR(nss,ix) = ptr;
8198 TOPPTR(nss,ix) = Nullop;
8203 TOPPTR(nss,ix) = Nullop;
8206 c = (char*)POPPTR(ss,ix);
8207 TOPPTR(nss,ix) = pv_dup_inc(c);
8210 longval = POPLONG(ss,ix);
8211 TOPLONG(nss,ix) = longval;
8214 hv = (HV*)POPPTR(ss,ix);
8215 TOPPTR(nss,ix) = hv_dup_inc(hv);
8216 c = (char*)POPPTR(ss,ix);
8217 TOPPTR(nss,ix) = pv_dup_inc(c);
8221 case SAVEt_DESTRUCTOR:
8222 ptr = POPPTR(ss,ix);
8223 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8224 dptr = POPDPTR(ss,ix);
8225 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8227 case SAVEt_DESTRUCTOR_X:
8228 ptr = POPPTR(ss,ix);
8229 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8230 dxptr = POPDXPTR(ss,ix);
8231 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8233 case SAVEt_REGCONTEXT:
8239 case SAVEt_STACK_POS: /* Position on Perl stack */
8243 case SAVEt_AELEM: /* array element */
8244 sv = (SV*)POPPTR(ss,ix);
8245 TOPPTR(nss,ix) = sv_dup_inc(sv);
8248 av = (AV*)POPPTR(ss,ix);
8249 TOPPTR(nss,ix) = av_dup_inc(av);
8251 case SAVEt_HELEM: /* hash element */
8252 sv = (SV*)POPPTR(ss,ix);
8253 TOPPTR(nss,ix) = sv_dup_inc(sv);
8254 sv = (SV*)POPPTR(ss,ix);
8255 TOPPTR(nss,ix) = sv_dup_inc(sv);
8256 hv = (HV*)POPPTR(ss,ix);
8257 TOPPTR(nss,ix) = hv_dup_inc(hv);
8260 ptr = POPPTR(ss,ix);
8261 TOPPTR(nss,ix) = ptr;
8268 av = (AV*)POPPTR(ss,ix);
8269 TOPPTR(nss,ix) = av_dup(av);
8272 longval = (long)POPLONG(ss,ix);
8273 TOPLONG(nss,ix) = longval;
8274 ptr = POPPTR(ss,ix);
8275 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8276 sv = (SV*)POPPTR(ss,ix);
8277 TOPPTR(nss,ix) = sv_dup(sv);
8280 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8292 perl_clone(PerlInterpreter *proto_perl, UV flags)
8295 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8298 #ifdef PERL_IMPLICIT_SYS
8299 return perl_clone_using(proto_perl, flags,
8301 proto_perl->IMemShared,
8302 proto_perl->IMemParse,
8312 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8313 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8314 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8315 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8316 struct IPerlDir* ipD, struct IPerlSock* ipS,
8317 struct IPerlProc* ipP)
8319 /* XXX many of the string copies here can be optimized if they're
8320 * constants; they need to be allocated as common memory and just
8321 * their pointers copied. */
8325 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8327 PERL_SET_THX(pPerl);
8328 # else /* !PERL_OBJECT */
8329 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8330 PERL_SET_THX(my_perl);
8333 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8338 # else /* !DEBUGGING */
8339 Zero(my_perl, 1, PerlInterpreter);
8340 # endif /* DEBUGGING */
8344 PL_MemShared = ipMS;
8352 # endif /* PERL_OBJECT */
8353 #else /* !PERL_IMPLICIT_SYS */
8355 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8356 PERL_SET_THX(my_perl);
8359 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8364 # else /* !DEBUGGING */
8365 Zero(my_perl, 1, PerlInterpreter);
8366 # endif /* DEBUGGING */
8367 #endif /* PERL_IMPLICIT_SYS */
8370 PL_xiv_arenaroot = NULL;
8372 PL_xnv_arenaroot = NULL;
8374 PL_xrv_arenaroot = NULL;
8376 PL_xpv_arenaroot = NULL;
8378 PL_xpviv_arenaroot = NULL;
8379 PL_xpviv_root = NULL;
8380 PL_xpvnv_arenaroot = NULL;
8381 PL_xpvnv_root = NULL;
8382 PL_xpvcv_arenaroot = NULL;
8383 PL_xpvcv_root = NULL;
8384 PL_xpvav_arenaroot = NULL;
8385 PL_xpvav_root = NULL;
8386 PL_xpvhv_arenaroot = NULL;
8387 PL_xpvhv_root = NULL;
8388 PL_xpvmg_arenaroot = NULL;
8389 PL_xpvmg_root = NULL;
8390 PL_xpvlv_arenaroot = NULL;
8391 PL_xpvlv_root = NULL;
8392 PL_xpvbm_arenaroot = NULL;
8393 PL_xpvbm_root = NULL;
8394 PL_he_arenaroot = NULL;
8396 PL_nice_chunk = NULL;
8397 PL_nice_chunk_size = 0;
8400 PL_sv_root = Nullsv;
8401 PL_sv_arenaroot = Nullsv;
8403 PL_debug = proto_perl->Idebug;
8405 /* create SV map for pointer relocation */
8406 PL_ptr_table = ptr_table_new();
8408 /* initialize these special pointers as early as possible */
8409 SvANY(&PL_sv_undef) = NULL;
8410 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8411 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8412 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8415 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8417 SvANY(&PL_sv_no) = new_XPVNV();
8419 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8420 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8421 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8422 SvCUR(&PL_sv_no) = 0;
8423 SvLEN(&PL_sv_no) = 1;
8424 SvNVX(&PL_sv_no) = 0;
8425 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8428 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8430 SvANY(&PL_sv_yes) = new_XPVNV();
8432 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8433 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8434 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8435 SvCUR(&PL_sv_yes) = 1;
8436 SvLEN(&PL_sv_yes) = 2;
8437 SvNVX(&PL_sv_yes) = 1;
8438 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8440 /* create shared string table */
8441 PL_strtab = newHV();
8442 HvSHAREKEYS_off(PL_strtab);
8443 hv_ksplit(PL_strtab, 512);
8444 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8446 PL_compiling = proto_perl->Icompiling;
8447 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8448 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8449 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8450 if (!specialWARN(PL_compiling.cop_warnings))
8451 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8452 if (!specialCopIO(PL_compiling.cop_io))
8453 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8454 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8456 /* pseudo environmental stuff */
8457 PL_origargc = proto_perl->Iorigargc;
8459 New(0, PL_origargv, i+1, char*);
8460 PL_origargv[i] = '\0';
8462 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8464 PL_envgv = gv_dup(proto_perl->Ienvgv);
8465 PL_incgv = gv_dup(proto_perl->Iincgv);
8466 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8467 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8468 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8469 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8472 PL_minus_c = proto_perl->Iminus_c;
8473 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8474 PL_localpatches = proto_perl->Ilocalpatches;
8475 PL_splitstr = proto_perl->Isplitstr;
8476 PL_preprocess = proto_perl->Ipreprocess;
8477 PL_minus_n = proto_perl->Iminus_n;
8478 PL_minus_p = proto_perl->Iminus_p;
8479 PL_minus_l = proto_perl->Iminus_l;
8480 PL_minus_a = proto_perl->Iminus_a;
8481 PL_minus_F = proto_perl->Iminus_F;
8482 PL_doswitches = proto_perl->Idoswitches;
8483 PL_dowarn = proto_perl->Idowarn;
8484 PL_doextract = proto_perl->Idoextract;
8485 PL_sawampersand = proto_perl->Isawampersand;
8486 PL_unsafe = proto_perl->Iunsafe;
8487 PL_inplace = SAVEPV(proto_perl->Iinplace);
8488 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8489 PL_perldb = proto_perl->Iperldb;
8490 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8492 /* magical thingies */
8493 /* XXX time(&PL_basetime) when asked for? */
8494 PL_basetime = proto_perl->Ibasetime;
8495 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8497 PL_maxsysfd = proto_perl->Imaxsysfd;
8498 PL_multiline = proto_perl->Imultiline;
8499 PL_statusvalue = proto_perl->Istatusvalue;
8501 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8504 /* shortcuts to various I/O objects */
8505 PL_stdingv = gv_dup(proto_perl->Istdingv);
8506 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8507 PL_defgv = gv_dup(proto_perl->Idefgv);
8508 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8509 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8510 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8512 /* shortcuts to regexp stuff */
8513 PL_replgv = gv_dup(proto_perl->Ireplgv);
8515 /* shortcuts to misc objects */
8516 PL_errgv = gv_dup(proto_perl->Ierrgv);
8518 /* shortcuts to debugging objects */
8519 PL_DBgv = gv_dup(proto_perl->IDBgv);
8520 PL_DBline = gv_dup(proto_perl->IDBline);
8521 PL_DBsub = gv_dup(proto_perl->IDBsub);
8522 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8523 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8524 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8525 PL_lineary = av_dup(proto_perl->Ilineary);
8526 PL_dbargs = av_dup(proto_perl->Idbargs);
8529 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8530 PL_curstash = hv_dup(proto_perl->Tcurstash);
8531 PL_debstash = hv_dup(proto_perl->Idebstash);
8532 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8533 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8535 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8536 PL_endav = av_dup_inc(proto_perl->Iendav);
8537 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8538 PL_initav = av_dup_inc(proto_perl->Iinitav);
8540 PL_sub_generation = proto_perl->Isub_generation;
8542 /* funky return mechanisms */
8543 PL_forkprocess = proto_perl->Iforkprocess;
8545 /* subprocess state */
8546 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8548 /* internal state */
8549 PL_tainting = proto_perl->Itainting;
8550 PL_maxo = proto_perl->Imaxo;
8551 if (proto_perl->Iop_mask)
8552 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8554 PL_op_mask = Nullch;
8556 /* current interpreter roots */
8557 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8558 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8559 PL_main_start = proto_perl->Imain_start;
8560 PL_eval_root = proto_perl->Ieval_root;
8561 PL_eval_start = proto_perl->Ieval_start;
8563 /* runtime control stuff */
8564 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8565 PL_copline = proto_perl->Icopline;
8567 PL_filemode = proto_perl->Ifilemode;
8568 PL_lastfd = proto_perl->Ilastfd;
8569 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8572 PL_gensym = proto_perl->Igensym;
8573 PL_preambled = proto_perl->Ipreambled;
8574 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8575 PL_laststatval = proto_perl->Ilaststatval;
8576 PL_laststype = proto_perl->Ilaststype;
8577 PL_mess_sv = Nullsv;
8579 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8580 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8582 /* interpreter atexit processing */
8583 PL_exitlistlen = proto_perl->Iexitlistlen;
8584 if (PL_exitlistlen) {
8585 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8586 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8589 PL_exitlist = (PerlExitListEntry*)NULL;
8590 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8592 PL_profiledata = NULL;
8593 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8594 /* PL_rsfp_filters entries have fake IoDIRP() */
8595 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8597 PL_compcv = cv_dup(proto_perl->Icompcv);
8598 PL_comppad = av_dup(proto_perl->Icomppad);
8599 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8600 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8601 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8602 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8603 proto_perl->Tcurpad);
8605 #ifdef HAVE_INTERP_INTERN
8606 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8609 /* more statics moved here */
8610 PL_generation = proto_perl->Igeneration;
8611 PL_DBcv = cv_dup(proto_perl->IDBcv);
8613 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8614 PL_in_clean_all = proto_perl->Iin_clean_all;
8616 PL_uid = proto_perl->Iuid;
8617 PL_euid = proto_perl->Ieuid;
8618 PL_gid = proto_perl->Igid;
8619 PL_egid = proto_perl->Iegid;
8620 PL_nomemok = proto_perl->Inomemok;
8621 PL_an = proto_perl->Ian;
8622 PL_cop_seqmax = proto_perl->Icop_seqmax;
8623 PL_op_seqmax = proto_perl->Iop_seqmax;
8624 PL_evalseq = proto_perl->Ievalseq;
8625 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8626 PL_origalen = proto_perl->Iorigalen;
8627 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8628 PL_osname = SAVEPV(proto_perl->Iosname);
8629 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8630 PL_sighandlerp = proto_perl->Isighandlerp;
8633 PL_runops = proto_perl->Irunops;
8635 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8638 PL_cshlen = proto_perl->Icshlen;
8639 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8642 PL_lex_state = proto_perl->Ilex_state;
8643 PL_lex_defer = proto_perl->Ilex_defer;
8644 PL_lex_expect = proto_perl->Ilex_expect;
8645 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8646 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8647 PL_lex_starts = proto_perl->Ilex_starts;
8648 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8649 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8650 PL_lex_op = proto_perl->Ilex_op;
8651 PL_lex_inpat = proto_perl->Ilex_inpat;
8652 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8653 PL_lex_brackets = proto_perl->Ilex_brackets;
8654 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8655 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8656 PL_lex_casemods = proto_perl->Ilex_casemods;
8657 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8658 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8660 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8661 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8662 PL_nexttoke = proto_perl->Inexttoke;
8664 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8665 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8666 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8667 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8668 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8669 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8670 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8671 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8672 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8673 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8674 PL_pending_ident = proto_perl->Ipending_ident;
8675 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8677 PL_expect = proto_perl->Iexpect;
8679 PL_multi_start = proto_perl->Imulti_start;
8680 PL_multi_end = proto_perl->Imulti_end;
8681 PL_multi_open = proto_perl->Imulti_open;
8682 PL_multi_close = proto_perl->Imulti_close;
8684 PL_error_count = proto_perl->Ierror_count;
8685 PL_subline = proto_perl->Isubline;
8686 PL_subname = sv_dup_inc(proto_perl->Isubname);
8688 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8689 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8690 PL_padix = proto_perl->Ipadix;
8691 PL_padix_floor = proto_perl->Ipadix_floor;
8692 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8694 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8695 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8696 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8697 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8698 PL_last_lop_op = proto_perl->Ilast_lop_op;
8699 PL_in_my = proto_perl->Iin_my;
8700 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8702 PL_cryptseen = proto_perl->Icryptseen;
8705 PL_hints = proto_perl->Ihints;
8707 PL_amagic_generation = proto_perl->Iamagic_generation;
8709 #ifdef USE_LOCALE_COLLATE
8710 PL_collation_ix = proto_perl->Icollation_ix;
8711 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8712 PL_collation_standard = proto_perl->Icollation_standard;
8713 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8714 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8715 #endif /* USE_LOCALE_COLLATE */
8717 #ifdef USE_LOCALE_NUMERIC
8718 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8719 PL_numeric_standard = proto_perl->Inumeric_standard;
8720 PL_numeric_local = proto_perl->Inumeric_local;
8721 PL_numeric_radix = proto_perl->Inumeric_radix;
8722 #endif /* !USE_LOCALE_NUMERIC */
8724 /* utf8 character classes */
8725 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8726 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8727 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8728 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8729 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8730 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8731 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8732 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8733 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8734 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8735 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8736 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8737 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8738 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8739 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8740 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8741 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8744 PL_last_swash_hv = Nullhv; /* reinits on demand */
8745 PL_last_swash_klen = 0;
8746 PL_last_swash_key[0]= '\0';
8747 PL_last_swash_tmps = (U8*)NULL;
8748 PL_last_swash_slen = 0;
8750 /* perly.c globals */
8751 PL_yydebug = proto_perl->Iyydebug;
8752 PL_yynerrs = proto_perl->Iyynerrs;
8753 PL_yyerrflag = proto_perl->Iyyerrflag;
8754 PL_yychar = proto_perl->Iyychar;
8755 PL_yyval = proto_perl->Iyyval;
8756 PL_yylval = proto_perl->Iyylval;
8758 PL_glob_index = proto_perl->Iglob_index;
8759 PL_srand_called = proto_perl->Isrand_called;
8760 PL_uudmap['M'] = 0; /* reinits on demand */
8761 PL_bitcount = Nullch; /* reinits on demand */
8763 if (proto_perl->Ipsig_ptr) {
8764 int sig_num[] = { SIG_NUM };
8765 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8766 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8767 for (i = 1; PL_sig_name[i]; i++) {
8768 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8769 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8773 PL_psig_ptr = (SV**)NULL;
8774 PL_psig_name = (SV**)NULL;
8777 /* thrdvar.h stuff */
8780 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8781 PL_tmps_ix = proto_perl->Ttmps_ix;
8782 PL_tmps_max = proto_perl->Ttmps_max;
8783 PL_tmps_floor = proto_perl->Ttmps_floor;
8784 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8786 while (i <= PL_tmps_ix) {
8787 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8791 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8792 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8793 Newz(54, PL_markstack, i, I32);
8794 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8795 - proto_perl->Tmarkstack);
8796 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8797 - proto_perl->Tmarkstack);
8798 Copy(proto_perl->Tmarkstack, PL_markstack,
8799 PL_markstack_ptr - PL_markstack + 1, I32);
8801 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8802 * NOTE: unlike the others! */
8803 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8804 PL_scopestack_max = proto_perl->Tscopestack_max;
8805 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8806 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8808 /* next push_return() sets PL_retstack[PL_retstack_ix]
8809 * NOTE: unlike the others! */
8810 PL_retstack_ix = proto_perl->Tretstack_ix;
8811 PL_retstack_max = proto_perl->Tretstack_max;
8812 Newz(54, PL_retstack, PL_retstack_max, OP*);
8813 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8815 /* NOTE: si_dup() looks at PL_markstack */
8816 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8818 /* PL_curstack = PL_curstackinfo->si_stack; */
8819 PL_curstack = av_dup(proto_perl->Tcurstack);
8820 PL_mainstack = av_dup(proto_perl->Tmainstack);
8822 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8823 PL_stack_base = AvARRAY(PL_curstack);
8824 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8825 - proto_perl->Tstack_base);
8826 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8828 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8829 * NOTE: unlike the others! */
8830 PL_savestack_ix = proto_perl->Tsavestack_ix;
8831 PL_savestack_max = proto_perl->Tsavestack_max;
8832 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8833 PL_savestack = ss_dup(proto_perl);
8837 ENTER; /* perl_destruct() wants to LEAVE; */
8840 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8841 PL_top_env = &PL_start_env;
8843 PL_op = proto_perl->Top;
8846 PL_Xpv = (XPV*)NULL;
8847 PL_na = proto_perl->Tna;
8849 PL_statbuf = proto_perl->Tstatbuf;
8850 PL_statcache = proto_perl->Tstatcache;
8851 PL_statgv = gv_dup(proto_perl->Tstatgv);
8852 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8854 PL_timesbuf = proto_perl->Ttimesbuf;
8857 PL_tainted = proto_perl->Ttainted;
8858 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8859 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8860 PL_rs = sv_dup_inc(proto_perl->Trs);
8861 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8862 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
8863 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8864 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8865 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8866 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8867 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8869 PL_restartop = proto_perl->Trestartop;
8870 PL_in_eval = proto_perl->Tin_eval;
8871 PL_delaymagic = proto_perl->Tdelaymagic;
8872 PL_dirty = proto_perl->Tdirty;
8873 PL_localizing = proto_perl->Tlocalizing;
8875 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8876 PL_protect = proto_perl->Tprotect;
8878 PL_errors = sv_dup_inc(proto_perl->Terrors);
8879 PL_av_fetch_sv = Nullsv;
8880 PL_hv_fetch_sv = Nullsv;
8881 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8882 PL_modcount = proto_perl->Tmodcount;
8883 PL_lastgotoprobe = Nullop;
8884 PL_dumpindent = proto_perl->Tdumpindent;
8886 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8887 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8888 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8889 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8890 PL_sortcxix = proto_perl->Tsortcxix;
8891 PL_efloatbuf = Nullch; /* reinits on demand */
8892 PL_efloatsize = 0; /* reinits on demand */
8896 PL_screamfirst = NULL;
8897 PL_screamnext = NULL;
8898 PL_maxscream = -1; /* reinits on demand */
8899 PL_lastscream = Nullsv;
8901 PL_watchaddr = NULL;
8902 PL_watchok = Nullch;
8904 PL_regdummy = proto_perl->Tregdummy;
8905 PL_regcomp_parse = Nullch;
8906 PL_regxend = Nullch;
8907 PL_regcode = (regnode*)NULL;
8910 PL_regprecomp = Nullch;
8915 PL_seen_zerolen = 0;
8917 PL_regcomp_rx = (regexp*)NULL;
8919 PL_colorset = 0; /* reinits PL_colors[] */
8920 /*PL_colors[6] = {0,0,0,0,0,0};*/
8921 PL_reg_whilem_seen = 0;
8922 PL_reginput = Nullch;
8925 PL_regstartp = (I32*)NULL;
8926 PL_regendp = (I32*)NULL;
8927 PL_reglastparen = (U32*)NULL;
8928 PL_regtill = Nullch;
8930 PL_reg_start_tmp = (char**)NULL;
8931 PL_reg_start_tmpl = 0;
8932 PL_regdata = (struct reg_data*)NULL;
8935 PL_reg_eval_set = 0;
8937 PL_regprogram = (regnode*)NULL;
8939 PL_regcc = (CURCUR*)NULL;
8940 PL_reg_call_cc = (struct re_cc_state*)NULL;
8941 PL_reg_re = (regexp*)NULL;
8942 PL_reg_ganch = Nullch;
8944 PL_reg_magic = (MAGIC*)NULL;
8946 PL_reg_oldcurpm = (PMOP*)NULL;
8947 PL_reg_curpm = (PMOP*)NULL;
8948 PL_reg_oldsaved = Nullch;
8949 PL_reg_oldsavedlen = 0;
8951 PL_reg_leftiter = 0;
8952 PL_reg_poscache = Nullch;
8953 PL_reg_poscache_size= 0;
8955 /* RE engine - function pointers */
8956 PL_regcompp = proto_perl->Tregcompp;
8957 PL_regexecp = proto_perl->Tregexecp;
8958 PL_regint_start = proto_perl->Tregint_start;
8959 PL_regint_string = proto_perl->Tregint_string;
8960 PL_regfree = proto_perl->Tregfree;
8962 PL_reginterp_cnt = 0;
8963 PL_reg_starttry = 0;
8966 return (PerlInterpreter*)pPerl;
8972 #else /* !USE_ITHREADS */
8978 #endif /* USE_ITHREADS */
8981 do_report_used(pTHXo_ SV *sv)
8983 if (SvTYPE(sv) != SVTYPEMASK) {
8984 PerlIO_printf(Perl_debug_log, "****\n");
8990 do_clean_objs(pTHXo_ SV *sv)
8994 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
8995 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
8996 if (SvWEAKREF(sv)) {
9007 /* XXX Might want to check arrays, etc. */
9010 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9012 do_clean_named_objs(pTHXo_ SV *sv)
9014 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9015 if ( SvOBJECT(GvSV(sv)) ||
9016 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9017 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9018 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9019 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9021 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9029 do_clean_all(pTHXo_ SV *sv)
9031 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9032 SvFLAGS(sv) |= SVf_BREAK;