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 /* With these two if statements:
1324 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1327 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1329 If you wish to remove them, please benchmark to see what the effect is
1331 if (u <= (UV)IV_MAX) {
1332 sv_setiv(sv, (IV)u);
1341 =for apidoc sv_setuv_mg
1343 Like C<sv_setuv>, but also handles 'set' magic.
1349 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1351 /* With these two if statements:
1352 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1355 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1357 If you wish to remove them, please benchmark to see what the effect is
1359 if (u <= (UV)IV_MAX) {
1360 sv_setiv(sv, (IV)u);
1370 =for apidoc sv_setnv
1372 Copies a double into the given SV. Does not handle 'set' magic. See
1379 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1381 SV_CHECK_THINKFIRST(sv);
1382 switch (SvTYPE(sv)) {
1385 sv_upgrade(sv, SVt_NV);
1390 sv_upgrade(sv, SVt_PVNV);
1399 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1400 PL_op_name[PL_op->op_type]);
1403 (void)SvNOK_only(sv); /* validate number */
1408 =for apidoc sv_setnv_mg
1410 Like C<sv_setnv>, but also handles 'set' magic.
1416 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1423 S_not_a_number(pTHX_ SV *sv)
1428 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1429 /* each *s can expand to 4 chars + "...\0",
1430 i.e. need room for 8 chars */
1432 for (s = SvPVX(sv); *s && d < limit; s++) {
1434 if (ch & 128 && !isPRINT_LC(ch)) {
1443 else if (ch == '\r') {
1447 else if (ch == '\f') {
1451 else if (ch == '\\') {
1455 else if (isPRINT_LC(ch))
1470 Perl_warner(aTHX_ WARN_NUMERIC,
1471 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1472 PL_op_desc[PL_op->op_type]);
1474 Perl_warner(aTHX_ WARN_NUMERIC,
1475 "Argument \"%s\" isn't numeric", tmpbuf);
1478 /* the number can be converted to integer with atol() or atoll() although */
1479 #define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
1480 #define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
1481 #define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
1482 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1483 #define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
1484 #define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
1485 #define IS_NUMBER_NEG 0x40 /* seen a leading - */
1486 #define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
1488 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1489 until proven guilty, assume that things are not that bad... */
1491 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1492 an IV (an assumption perl has been based on to date) it becomes necessary
1493 to remove the assumption that the NV always carries enough precision to
1494 recreate the IV whenever needed, and that the NV is the canonical form.
1495 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1496 precision as an side effect of conversion (which would lead to insanity
1497 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1498 1) to distinguish between IV/UV/NV slots that have cached a valid
1499 conversion where precision was lost and IV/UV/NV slots that have a
1500 valid conversion which has lost no precision
1501 2) to ensure that if a numeric conversion to one form is request that
1502 would lose precision, the precise conversion (or differently
1503 imprecise conversion) is also performed and cached, to prevent
1504 requests for different numeric formats on the same SV causing
1505 lossy conversion chains. (lossless conversion chains are perfectly
1510 SvIOKp is true if the IV slot contains a valid value
1511 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1512 SvNOKp is true if the NV slot contains a valid value
1513 SvNOK is true only if the NV value is accurate
1516 while converting from PV to NV check to see if converting that NV to an
1517 IV(or UV) would lose accuracy over a direct conversion from PV to
1518 IV(or UV). If it would, cache both conversions, return NV, but mark
1519 SV as IOK NOKp (ie not NOK).
1521 while converting from PV to IV check to see if converting that IV to an
1522 NV would lose accuracy over a direct conversion from PV to NV. If it
1523 would, cache both conversions, flag similarly.
1525 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1526 correctly because if IV & NV were set NV *always* overruled.
1527 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1528 changes - now IV and NV together means that the two are interchangeable
1529 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1531 The benefit of this is operations such as pp_add know that if SvIOK is
1532 true for both left and right operands, then integer addition can be
1533 used instead of floating point. (for cases where the result won't
1534 overflow) Before, floating point was always used, which could lead to
1535 loss of precision compared with integer addition.
1537 * making IV and NV equal status should make maths accurate on 64 bit
1539 * may speed up maths somewhat if pp_add and friends start to use
1540 integers when possible instead of fp. (hopefully the overhead in
1541 looking for SvIOK and checking for overflow will not outweigh the
1542 fp to integer speedup)
1543 * will slow down integer operations (callers of SvIV) on "inaccurate"
1544 values, as the change from SvIOK to SvIOKp will cause a call into
1545 sv_2iv each time rather than a macro access direct to the IV slot
1546 * should speed up number->string conversion on integers as IV is
1547 favoured when IV and NV equally accurate
1549 ####################################################################
1550 You had better be using SvIOK_notUV if you want an IV for arithmetic
1551 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1552 SvUOK is true iff UV.
1553 ####################################################################
1555 Your mileage will vary depending your CPUs relative fp to integer
1559 #ifndef NV_PRESERVES_UV
1560 #define IS_NUMBER_UNDERFLOW_IV 1
1561 #define IS_NUMBER_UNDERFLOW_UV 2
1562 #define IS_NUMBER_IV_AND_UV 2
1563 #define IS_NUMBER_OVERFLOW_IV 4
1564 #define IS_NUMBER_OVERFLOW_UV 5
1565 /* Hopefully your optimiser will consider inlining these two functions. */
1567 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1568 NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
1569 UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
1570 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype));
1571 if (nv_as_uv <= (UV)IV_MAX) {
1572 (void)SvIOKp_on(sv);
1573 (void)SvNOKp_on(sv);
1574 /* Within suitable range to fit in an IV, atol won't overflow */
1575 /* XXX quite sure? Is that your final answer? not really, I'm
1576 trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1577 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1578 if (numtype & IS_NUMBER_NOT_INT) {
1579 /* I believe that even if the original PV had decimals, they
1580 are lost beyond the limit of the FP precision.
1581 However, neither is canonical, so both only get p flags.
1583 /* Both already have p flags, so do nothing */
1584 } else if (SvIVX(sv) == I_V(nv)) {
1589 /* It had no "." so it must be integer. assert (get in here from
1590 sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1591 IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1592 conversion routines need audit. */
1594 return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1596 /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1597 (void)SvIOKp_on(sv);
1598 (void)SvNOKp_on(sv);
1601 int save_errno = errno;
1603 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1605 if (numtype & IS_NUMBER_NOT_INT) {
1606 /* UV and NV both imprecise. */
1608 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1617 return IS_NUMBER_OVERFLOW_IV;
1621 /* Must have just overflowed UV, but not enough that an NV could spot
1623 return IS_NUMBER_OVERFLOW_UV;
1626 /* We've just lost integer precision, nothing we could do. */
1627 SvUVX(sv) = nv_as_uv;
1628 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype));
1629 /* UV and NV slots equally valid only if we have casting symmetry. */
1630 if (numtype & IS_NUMBER_NOT_INT) {
1632 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1633 /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1634 UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1635 get to this point if NVs don't preserve UVs) */
1640 /* As above, I believe UV at least as good as NV */
1643 #endif /* HAS_STRTOUL */
1644 return IS_NUMBER_OVERFLOW_IV;
1647 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1649 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1651 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype));
1652 if (SvNVX(sv) < (NV)IV_MIN) {
1653 (void)SvIOKp_on(sv);
1656 return IS_NUMBER_UNDERFLOW_IV;
1658 if (SvNVX(sv) > (NV)UV_MAX) {
1659 (void)SvIOKp_on(sv);
1663 return IS_NUMBER_OVERFLOW_UV;
1665 if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1666 (void)SvIOKp_on(sv);
1668 /* Can't use strtol etc to convert this string */
1669 if (SvNVX(sv) <= (UV)IV_MAX) {
1670 SvIVX(sv) = I_V(SvNVX(sv));
1671 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1672 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1674 /* Integer is imprecise. NOK, IOKp */
1676 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1679 SvUVX(sv) = U_V(SvNVX(sv));
1680 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1681 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1683 /* Integer is imprecise. NOK, IOKp */
1685 return IS_NUMBER_OVERFLOW_IV;
1687 return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
1689 #endif /* NV_PRESERVES_UV*/
1692 Perl_sv_2iv(pTHX_ register SV *sv)
1696 if (SvGMAGICAL(sv)) {
1701 return I_V(SvNVX(sv));
1703 if (SvPOKp(sv) && SvLEN(sv))
1706 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1707 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1713 if (SvTHINKFIRST(sv)) {
1716 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1717 (SvRV(tmpstr) != SvRV(sv)))
1718 return SvIV(tmpstr);
1719 return PTR2IV(SvRV(sv));
1721 if (SvREADONLY(sv) && SvFAKE(sv)) {
1722 sv_force_normal(sv);
1724 if (SvREADONLY(sv) && !SvOK(sv)) {
1725 if (ckWARN(WARN_UNINITIALIZED))
1732 return (IV)(SvUVX(sv));
1739 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1740 * without also getting a cached IV/UV from it at the same time
1741 * (ie PV->NV conversion should detect loss of accuracy and cache
1742 * IV or UV at same time to avoid this. NWC */
1744 if (SvTYPE(sv) == SVt_NV)
1745 sv_upgrade(sv, SVt_PVNV);
1747 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1748 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1749 certainly cast into the IV range at IV_MAX, whereas the correct
1750 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1752 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1753 SvIVX(sv) = I_V(SvNVX(sv));
1754 if (SvNVX(sv) == (NV) SvIVX(sv)
1755 #ifndef NV_PRESERVES_UV
1756 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1757 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1758 /* Don't flag it as "accurately an integer" if the number
1759 came from a (by definition imprecise) NV operation, and
1760 we're outside the range of NV integer precision */
1763 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1764 DEBUG_c(PerlIO_printf(Perl_debug_log,
1765 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1771 /* IV not precise. No need to convert from PV, as NV
1772 conversion would already have cached IV if it detected
1773 that PV->IV would be better than PV->NV->IV
1774 flags already correct - don't set public IOK. */
1775 DEBUG_c(PerlIO_printf(Perl_debug_log,
1776 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1781 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1782 but the cast (NV)IV_MIN rounds to a the value less (more
1783 negative) than IV_MIN which happens to be equal to SvNVX ??
1784 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1785 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1786 (NV)UVX == NVX are both true, but the values differ. :-(
1787 Hopefully for 2s complement IV_MIN is something like
1788 0x8000000000000000 which will be exact. NWC */
1791 SvUVX(sv) = U_V(SvNVX(sv));
1793 (SvNVX(sv) == (NV) SvUVX(sv))
1794 #ifndef NV_PRESERVES_UV
1795 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1796 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1797 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1798 /* Don't flag it as "accurately an integer" if the number
1799 came from a (by definition imprecise) NV operation, and
1800 we're outside the range of NV integer precision */
1806 DEBUG_c(PerlIO_printf(Perl_debug_log,
1807 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1811 return (IV)SvUVX(sv);
1814 else if (SvPOKp(sv) && SvLEN(sv)) {
1815 I32 numtype = looks_like_number(sv);
1817 /* We want to avoid a possible problem when we cache an IV which
1818 may be later translated to an NV, and the resulting NV is not
1819 the translation of the initial data.
1821 This means that if we cache such an IV, we need to cache the
1822 NV as well. Moreover, we trade speed for space, and do not
1823 cache the NV if we are sure it's not needed.
1826 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1827 /* The NV may be reconstructed from IV - safe to cache IV,
1828 which may be calculated by atol(). */
1829 if (SvTYPE(sv) < SVt_PVIV)
1830 sv_upgrade(sv, SVt_PVIV);
1832 SvIVX(sv) = Atol(SvPVX(sv));
1836 int save_errno = errno;
1837 /* Is it an integer that we could convert with strtol?
1838 So try it, and if it doesn't set errno then it's pukka.
1839 This should be faster than going atof and then thinking. */
1840 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1841 == IS_NUMBER_TO_INT_BY_STRTOL)
1842 /* && is a sequence point. Without it not sure if I'm trying
1843 to do too much between sequence points and hence going
1845 && ((errno = 0), 1) /* , 1 so always true */
1846 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1848 if (SvTYPE(sv) < SVt_PVIV)
1849 sv_upgrade(sv, SVt_PVIV);
1858 /* Hopefully trace flow will optimise this away where possible
1862 /* It wasn't an integer, or it overflowed, or we don't have
1863 strtol. Do things the slow way - check if it's a UV etc. */
1864 d = Atof(SvPVX(sv));
1866 if (SvTYPE(sv) < SVt_PVNV)
1867 sv_upgrade(sv, SVt_PVNV);
1870 if (! numtype && ckWARN(WARN_NUMERIC))
1873 #if defined(USE_LONG_DOUBLE)
1874 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1875 PTR2UV(sv), SvNVX(sv)));
1877 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1878 PTR2UV(sv), SvNVX(sv)));
1882 #ifdef NV_PRESERVES_UV
1883 (void)SvIOKp_on(sv);
1885 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1886 SvIVX(sv) = I_V(SvNVX(sv));
1887 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1890 /* Integer is imprecise. NOK, IOKp */
1892 /* UV will not work better than IV */
1894 if (SvNVX(sv) > (NV)UV_MAX) {
1896 /* Integer is inaccurate. NOK, IOKp, is UV */
1900 SvUVX(sv) = U_V(SvNVX(sv));
1901 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1902 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1906 /* Integer is imprecise. NOK, IOKp, is UV */
1912 #else /* NV_PRESERVES_UV */
1913 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1914 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1915 /* Small enough to preserve all bits. */
1916 (void)SvIOKp_on(sv);
1918 SvIVX(sv) = I_V(SvNVX(sv));
1919 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1921 /* Assumption: first non-preserved integer is < IV_MAX,
1922 this NV is in the preserved range, therefore: */
1923 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1925 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);
1927 } else if (sv_2iuv_non_preserve (sv, numtype)
1928 >= IS_NUMBER_OVERFLOW_IV)
1930 #endif /* NV_PRESERVES_UV */
1934 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1936 if (SvTYPE(sv) < SVt_IV)
1937 /* Typically the caller expects that sv_any is not NULL now. */
1938 sv_upgrade(sv, SVt_IV);
1941 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1942 PTR2UV(sv),SvIVX(sv)));
1943 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1947 Perl_sv_2uv(pTHX_ register SV *sv)
1951 if (SvGMAGICAL(sv)) {
1956 return U_V(SvNVX(sv));
1957 if (SvPOKp(sv) && SvLEN(sv))
1960 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1961 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1967 if (SvTHINKFIRST(sv)) {
1970 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1971 (SvRV(tmpstr) != SvRV(sv)))
1972 return SvUV(tmpstr);
1973 return PTR2UV(SvRV(sv));
1975 if (SvREADONLY(sv) && SvFAKE(sv)) {
1976 sv_force_normal(sv);
1978 if (SvREADONLY(sv) && !SvOK(sv)) {
1979 if (ckWARN(WARN_UNINITIALIZED))
1989 return (UV)SvIVX(sv);
1993 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1994 * without also getting a cached IV/UV from it at the same time
1995 * (ie PV->NV conversion should detect loss of accuracy and cache
1996 * IV or UV at same time to avoid this. */
1997 /* IV-over-UV optimisation - choose to cache IV if possible */
1999 if (SvTYPE(sv) == SVt_NV)
2000 sv_upgrade(sv, SVt_PVNV);
2002 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2003 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2004 SvIVX(sv) = I_V(SvNVX(sv));
2005 if (SvNVX(sv) == (NV) SvIVX(sv)
2006 #ifndef NV_PRESERVES_UV
2007 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2008 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2009 /* Don't flag it as "accurately an integer" if the number
2010 came from a (by definition imprecise) NV operation, and
2011 we're outside the range of NV integer precision */
2014 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2015 DEBUG_c(PerlIO_printf(Perl_debug_log,
2016 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2022 /* IV not precise. No need to convert from PV, as NV
2023 conversion would already have cached IV if it detected
2024 that PV->IV would be better than PV->NV->IV
2025 flags already correct - don't set public IOK. */
2026 DEBUG_c(PerlIO_printf(Perl_debug_log,
2027 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2032 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2033 but the cast (NV)IV_MIN rounds to a the value less (more
2034 negative) than IV_MIN which happens to be equal to SvNVX ??
2035 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2036 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2037 (NV)UVX == NVX are both true, but the values differ. :-(
2038 Hopefully for 2s complement IV_MIN is something like
2039 0x8000000000000000 which will be exact. NWC */
2042 SvUVX(sv) = U_V(SvNVX(sv));
2044 (SvNVX(sv) == (NV) SvUVX(sv))
2045 #ifndef NV_PRESERVES_UV
2046 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2047 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2048 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2049 /* Don't flag it as "accurately an integer" if the number
2050 came from a (by definition imprecise) NV operation, and
2051 we're outside the range of NV integer precision */
2056 DEBUG_c(PerlIO_printf(Perl_debug_log,
2057 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2063 else if (SvPOKp(sv) && SvLEN(sv)) {
2064 I32 numtype = looks_like_number(sv);
2066 /* We want to avoid a possible problem when we cache a UV which
2067 may be later translated to an NV, and the resulting NV is not
2068 the translation of the initial data.
2070 This means that if we cache such a UV, we need to cache the
2071 NV as well. Moreover, we trade speed for space, and do not
2072 cache the NV if not needed.
2075 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2076 /* The NV may be reconstructed from IV - safe to cache IV,
2077 which may be calculated by atol(). */
2078 if (SvTYPE(sv) < SVt_PVIV)
2079 sv_upgrade(sv, SVt_PVIV);
2081 SvIVX(sv) = Atol(SvPVX(sv));
2085 char *num_begin = SvPVX(sv);
2086 int save_errno = errno;
2088 /* seems that strtoul taking numbers that start with - is
2089 implementation dependant, and can't be relied upon. */
2090 if (numtype & IS_NUMBER_NEG) {
2091 /* Not totally defensive. assumine that looks_like_num
2092 didn't lie about a - sign */
2093 while (isSPACE(*num_begin))
2095 if (*num_begin == '-')
2099 /* Is it an integer that we could convert with strtoul?
2100 So try it, and if it doesn't set errno then it's pukka.
2101 This should be faster than going atof and then thinking. */
2102 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2103 == IS_NUMBER_TO_INT_BY_STRTOL)
2104 && ((errno = 0), 1) /* always true */
2105 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2107 /* If known to be negative, check it didn't undeflow IV
2108 XXX possibly we should put more negative values as NVs
2109 direct rather than go via atof below */
2110 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2113 if (SvTYPE(sv) < SVt_PVIV)
2114 sv_upgrade(sv, SVt_PVIV);
2117 /* If it's negative must use IV.
2118 IV-over-UV optimisation */
2119 if (numtype & IS_NUMBER_NEG) {
2121 } else if (u <= (UV) IV_MAX) {
2124 /* it didn't overflow, and it was positive. */
2133 /* Hopefully trace flow will optimise this away where possible
2137 /* It wasn't an integer, or it overflowed, or we don't have
2138 strtol. Do things the slow way - check if it's a IV etc. */
2139 d = Atof(SvPVX(sv));
2141 if (SvTYPE(sv) < SVt_PVNV)
2142 sv_upgrade(sv, SVt_PVNV);
2145 if (! numtype && ckWARN(WARN_NUMERIC))
2148 #if defined(USE_LONG_DOUBLE)
2149 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2150 PTR2UV(sv), SvNVX(sv)));
2152 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2153 PTR2UV(sv), SvNVX(sv)));
2156 #ifdef NV_PRESERVES_UV
2157 (void)SvIOKp_on(sv);
2159 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2160 SvIVX(sv) = I_V(SvNVX(sv));
2161 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2164 /* Integer is imprecise. NOK, IOKp */
2166 /* UV will not work better than IV */
2168 if (SvNVX(sv) > (NV)UV_MAX) {
2170 /* Integer is inaccurate. NOK, IOKp, is UV */
2174 SvUVX(sv) = U_V(SvNVX(sv));
2175 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2176 NV preservse UV so can do correct comparison. */
2177 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2181 /* Integer is imprecise. NOK, IOKp, is UV */
2186 #else /* NV_PRESERVES_UV */
2187 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2188 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2189 /* Small enough to preserve all bits. */
2190 (void)SvIOKp_on(sv);
2192 SvIVX(sv) = I_V(SvNVX(sv));
2193 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2195 /* Assumption: first non-preserved integer is < IV_MAX,
2196 this NV is in the preserved range, therefore: */
2197 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2199 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);
2202 sv_2iuv_non_preserve (sv, numtype);
2203 #endif /* NV_PRESERVES_UV */
2208 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2209 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2212 if (SvTYPE(sv) < SVt_IV)
2213 /* Typically the caller expects that sv_any is not NULL now. */
2214 sv_upgrade(sv, SVt_IV);
2218 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2219 PTR2UV(sv),SvUVX(sv)));
2220 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2224 Perl_sv_2nv(pTHX_ register SV *sv)
2228 if (SvGMAGICAL(sv)) {
2232 if (SvPOKp(sv) && SvLEN(sv)) {
2233 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2235 return Atof(SvPVX(sv));
2239 return (NV)SvUVX(sv);
2241 return (NV)SvIVX(sv);
2244 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2245 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2251 if (SvTHINKFIRST(sv)) {
2254 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2255 (SvRV(tmpstr) != SvRV(sv)))
2256 return SvNV(tmpstr);
2257 return PTR2NV(SvRV(sv));
2259 if (SvREADONLY(sv) && SvFAKE(sv)) {
2260 sv_force_normal(sv);
2262 if (SvREADONLY(sv) && !SvOK(sv)) {
2263 if (ckWARN(WARN_UNINITIALIZED))
2268 if (SvTYPE(sv) < SVt_NV) {
2269 if (SvTYPE(sv) == SVt_IV)
2270 sv_upgrade(sv, SVt_PVNV);
2272 sv_upgrade(sv, SVt_NV);
2273 #if defined(USE_LONG_DOUBLE)
2275 STORE_NUMERIC_LOCAL_SET_STANDARD();
2276 PerlIO_printf(Perl_debug_log,
2277 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2278 PTR2UV(sv), SvNVX(sv));
2279 RESTORE_NUMERIC_LOCAL();
2283 STORE_NUMERIC_LOCAL_SET_STANDARD();
2284 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2285 PTR2UV(sv), SvNVX(sv));
2286 RESTORE_NUMERIC_LOCAL();
2290 else if (SvTYPE(sv) < SVt_PVNV)
2291 sv_upgrade(sv, SVt_PVNV);
2293 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2295 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2296 #ifdef NV_PRESERVES_UV
2299 /* Only set the public NV OK flag if this NV preserves the IV */
2300 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2301 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2302 : (SvIVX(sv) == I_V(SvNVX(sv))))
2308 else if (SvPOKp(sv) && SvLEN(sv)) {
2309 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2311 SvNVX(sv) = Atof(SvPVX(sv));
2312 #ifdef NV_PRESERVES_UV
2315 /* Only set the public NV OK flag if this NV preserves the value in
2316 the PV at least as well as an IV/UV would.
2317 Not sure how to do this 100% reliably. */
2318 /* if that shift count is out of range then Configure's test is
2319 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2321 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2322 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2323 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2324 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2325 /* Definitely too large/small to fit in an integer, so no loss
2326 of precision going to integer in the future via NV */
2329 /* Is it something we can run through strtol etc (ie no
2330 trailing exponent part)? */
2331 int numtype = looks_like_number(sv);
2332 /* XXX probably should cache this if called above */
2335 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2336 /* Can't use strtol etc to convert this string, so don't try */
2339 sv_2inuv_non_preserve (sv, numtype);
2341 #endif /* NV_PRESERVES_UV */
2344 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2346 if (SvTYPE(sv) < SVt_NV)
2347 /* Typically the caller expects that sv_any is not NULL now. */
2348 /* XXX Ilya implies that this is a bug in callers that assume this
2349 and ideally should be fixed. */
2350 sv_upgrade(sv, SVt_NV);
2353 #if defined(USE_LONG_DOUBLE)
2355 STORE_NUMERIC_LOCAL_SET_STANDARD();
2356 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2357 PTR2UV(sv), SvNVX(sv));
2358 RESTORE_NUMERIC_LOCAL();
2362 STORE_NUMERIC_LOCAL_SET_STANDARD();
2363 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2364 PTR2UV(sv), SvNVX(sv));
2365 RESTORE_NUMERIC_LOCAL();
2372 S_asIV(pTHX_ SV *sv)
2374 I32 numtype = looks_like_number(sv);
2377 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2378 return Atol(SvPVX(sv));
2380 if (ckWARN(WARN_NUMERIC))
2383 d = Atof(SvPVX(sv));
2388 S_asUV(pTHX_ SV *sv)
2390 I32 numtype = looks_like_number(sv);
2393 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2394 return Strtoul(SvPVX(sv), Null(char**), 10);
2397 if (ckWARN(WARN_NUMERIC))
2400 return U_V(Atof(SvPVX(sv)));
2404 * Returns a combination of (advisory only - can get false negatives)
2405 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2406 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2407 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2408 * 0 if does not look like number.
2410 * (atol and strtol stop when they hit a decimal point. strtol will return
2411 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2412 * do this, and vendors have had 11 years to get it right.
2413 * However, will try to make it still work with only atol
2415 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2416 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2417 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2418 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2419 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2420 * IS_NUMBER_NOT_INT saw "." or "e"
2422 * IS_NUMBER_INFINITY
2426 =for apidoc looks_like_number
2428 Test if an the content of an SV looks like a number (or is a
2429 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2430 issue a non-numeric warning), even if your atof() doesn't grok them.
2436 Perl_looks_like_number(pTHX_ SV *sv)
2439 register char *send;
2440 register char *sbegin;
2441 register char *nbegin;
2450 else if (SvPOKp(sv))
2451 sbegin = SvPV(sv, len);
2454 send = sbegin + len;
2461 numtype = IS_NUMBER_NEG;
2468 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2469 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2470 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2471 * will need (int)atof().
2474 /* next must be digit or the radix separator or beginning of infinity */
2478 } while (isDIGIT(*s));
2480 /* Aaargh. long long really is irritating.
2481 In the gospel according to ANSI 1989, it is an axiom that "long"
2482 is the longest integer type, and that if you don't know how long
2483 something is you can cast it to long, and nothing will be lost
2484 (except possibly speed of execution if long is slower than the
2486 Now, one can't be sure if the old rules apply, or long long
2487 (or some other newfangled thing) is actually longer than the
2488 (formerly) longest thing.
2490 /* This lot will work for 64 bit *as long as* either
2491 either long is 64 bit
2492 or we can find both strtol/strtoq and strtoul/strtouq
2493 If not, we really should refuse to let the user use 64 bit IVs
2494 By "64 bit" I really mean IVs that don't get preserved by NVs
2495 It also should work for 128 bit IVs. Can any lend me a machine to
2498 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2499 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2500 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2501 ? sizeof(long) : sizeof (IV))*8-1))
2502 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2504 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2505 digit less (IV_MAX= 9223372036854775807,
2506 UV_MAX= 18446744073709551615) so be cautious */
2507 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2510 #ifdef USE_LOCALE_NUMERIC
2511 || IS_NUMERIC_RADIX(*s)
2515 numtype |= IS_NUMBER_NOT_INT;
2516 while (isDIGIT(*s)) /* optional digits after the radix */
2521 #ifdef USE_LOCALE_NUMERIC
2522 || IS_NUMERIC_RADIX(*s)
2526 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2527 /* no digits before the radix means we need digits after it */
2531 } while (isDIGIT(*s));
2536 else if (*s == 'I' || *s == 'i') {
2537 s++; if (*s != 'N' && *s != 'n') return 0;
2538 s++; if (*s != 'F' && *s != 'f') return 0;
2539 s++; if (*s == 'I' || *s == 'i') {
2540 s++; if (*s != 'N' && *s != 'n') return 0;
2541 s++; if (*s != 'I' && *s != 'i') return 0;
2542 s++; if (*s != 'T' && *s != 't') return 0;
2543 s++; if (*s != 'Y' && *s != 'y') return 0;
2552 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2553 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2555 /* we can have an optional exponent part */
2556 if (*s == 'e' || *s == 'E') {
2557 numtype &= IS_NUMBER_NEG;
2558 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2560 if (*s == '+' || *s == '-')
2565 } while (isDIGIT(*s));
2575 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2576 return IS_NUMBER_TO_INT_BY_ATOL;
2581 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2584 return sv_2pv(sv, &n_a);
2587 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2589 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2591 char *ptr = buf + TYPE_CHARS(UV);
2605 *--ptr = '0' + (uv % 10);
2614 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2619 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2620 char *tmpbuf = tbuf;
2626 if (SvGMAGICAL(sv)) {
2634 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2636 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2641 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2646 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2647 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2654 if (SvTHINKFIRST(sv)) {
2657 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2658 (SvRV(tmpstr) != SvRV(sv)))
2659 return SvPV(tmpstr,*lp);
2666 switch (SvTYPE(sv)) {
2668 if ( ((SvFLAGS(sv) &
2669 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2670 == (SVs_OBJECT|SVs_RMG))
2671 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2672 && (mg = mg_find(sv, 'r'))) {
2673 regexp *re = (regexp *)mg->mg_obj;
2676 char *fptr = "msix";
2681 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2683 while((ch = *fptr++)) {
2685 reflags[left++] = ch;
2688 reflags[right--] = ch;
2693 reflags[left] = '-';
2697 mg->mg_len = re->prelen + 4 + left;
2698 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2699 Copy("(?", mg->mg_ptr, 2, char);
2700 Copy(reflags, mg->mg_ptr+2, left, char);
2701 Copy(":", mg->mg_ptr+left+2, 1, char);
2702 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2703 mg->mg_ptr[mg->mg_len - 1] = ')';
2704 mg->mg_ptr[mg->mg_len] = 0;
2706 PL_reginterp_cnt += re->program[0].next_off;
2718 case SVt_PVBM: if (SvROK(sv))
2721 s = "SCALAR"; break;
2722 case SVt_PVLV: s = "LVALUE"; break;
2723 case SVt_PVAV: s = "ARRAY"; break;
2724 case SVt_PVHV: s = "HASH"; break;
2725 case SVt_PVCV: s = "CODE"; break;
2726 case SVt_PVGV: s = "GLOB"; break;
2727 case SVt_PVFM: s = "FORMAT"; break;
2728 case SVt_PVIO: s = "IO"; break;
2729 default: s = "UNKNOWN"; break;
2733 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2736 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2742 if (SvREADONLY(sv) && !SvOK(sv)) {
2743 if (ckWARN(WARN_UNINITIALIZED))
2749 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2750 /* I'm assuming that if both IV and NV are equally valid then
2751 converting the IV is going to be more efficient */
2752 U32 isIOK = SvIOK(sv);
2753 U32 isUIOK = SvIsUV(sv);
2754 char buf[TYPE_CHARS(UV)];
2757 if (SvTYPE(sv) < SVt_PVIV)
2758 sv_upgrade(sv, SVt_PVIV);
2760 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2762 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2763 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2764 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2765 SvCUR_set(sv, ebuf - ptr);
2775 else if (SvNOKp(sv)) {
2776 if (SvTYPE(sv) < SVt_PVNV)
2777 sv_upgrade(sv, SVt_PVNV);
2778 /* The +20 is pure guesswork. Configure test needed. --jhi */
2779 SvGROW(sv, NV_DIG + 20);
2781 olderrno = errno; /* some Xenix systems wipe out errno here */
2783 if (SvNVX(sv) == 0.0)
2784 (void)strcpy(s,"0");
2788 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2791 #ifdef FIXNEGATIVEZERO
2792 if (*s == '-' && s[1] == '0' && !s[2])
2802 if (ckWARN(WARN_UNINITIALIZED)
2803 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2806 if (SvTYPE(sv) < SVt_PV)
2807 /* Typically the caller expects that sv_any is not NULL now. */
2808 sv_upgrade(sv, SVt_PV);
2811 *lp = s - SvPVX(sv);
2814 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2815 PTR2UV(sv),SvPVX(sv)));
2819 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2820 /* Sneaky stuff here */
2824 tsv = newSVpv(tmpbuf, 0);
2840 len = strlen(tmpbuf);
2842 #ifdef FIXNEGATIVEZERO
2843 if (len == 2 && t[0] == '-' && t[1] == '0') {
2848 (void)SvUPGRADE(sv, SVt_PV);
2850 s = SvGROW(sv, len + 1);
2859 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2862 return sv_2pvbyte(sv, &n_a);
2866 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2868 return sv_2pv(sv,lp);
2872 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2875 return sv_2pvutf8(sv, &n_a);
2879 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2881 sv_utf8_upgrade(sv);
2882 return SvPV(sv,*lp);
2885 /* This function is only called on magical items */
2887 Perl_sv_2bool(pTHX_ register SV *sv)
2896 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2897 (SvRV(tmpsv) != SvRV(sv)))
2898 return SvTRUE(tmpsv);
2899 return SvRV(sv) != 0;
2902 register XPV* Xpvtmp;
2903 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2904 (*Xpvtmp->xpv_pv > '0' ||
2905 Xpvtmp->xpv_cur > 1 ||
2906 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2913 return SvIVX(sv) != 0;
2916 return SvNVX(sv) != 0.0;
2924 =for apidoc sv_utf8_upgrade
2926 Convert the PV of an SV to its UTF8-encoded form.
2932 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2937 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2940 /* This function could be much more efficient if we had a FLAG in SVs
2941 * to signal if there are any hibit chars in the PV.
2942 * Given that there isn't make loop fast as possible
2948 if ((hibit = *t++ & 0x80))
2954 if (SvREADONLY(sv) && SvFAKE(sv)) {
2955 sv_force_normal(sv);
2958 len = SvCUR(sv) + 1; /* Plus the \0 */
2959 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2960 SvCUR(sv) = len - 1;
2962 Safefree(s); /* No longer using what was there before. */
2963 SvLEN(sv) = len; /* No longer know the real size. */
2969 =for apidoc sv_utf8_downgrade
2971 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2972 This may not be possible if the PV contains non-byte encoding characters;
2973 if this is the case, either returns false or, if C<fail_ok> is not
2980 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2982 if (SvPOK(sv) && SvUTF8(sv)) {
2984 char *c = SvPVX(sv);
2985 STRLEN len = SvCUR(sv);
2987 if (!utf8_to_bytes((U8*)c, &len)) {
2992 Perl_croak(aTHX_ "Wide character in %s",
2993 PL_op_desc[PL_op->op_type]);
2995 Perl_croak(aTHX_ "Wide character");
3007 =for apidoc sv_utf8_encode
3009 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3010 flag so that it looks like bytes again. Nothing calls this.
3016 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3018 sv_utf8_upgrade(sv);
3023 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3028 bool has_utf = FALSE;
3029 if (!sv_utf8_downgrade(sv, TRUE))
3032 /* it is actually just a matter of turning the utf8 flag on, but
3033 * we want to make sure everything inside is valid utf8 first.
3036 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
3050 /* Note: sv_setsv() should not be called with a source string that needs
3051 * to be reused, since it may destroy the source string if it is marked
3056 =for apidoc sv_setsv
3058 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3059 The source SV may be destroyed if it is mortal. Does not handle 'set'
3060 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3067 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3069 register U32 sflags;
3075 SV_CHECK_THINKFIRST(dstr);
3077 sstr = &PL_sv_undef;
3078 stype = SvTYPE(sstr);
3079 dtype = SvTYPE(dstr);
3083 /* There's a lot of redundancy below but we're going for speed here */
3088 if (dtype != SVt_PVGV) {
3089 (void)SvOK_off(dstr);
3097 sv_upgrade(dstr, SVt_IV);
3100 sv_upgrade(dstr, SVt_PVNV);
3104 sv_upgrade(dstr, SVt_PVIV);
3107 (void)SvIOK_only(dstr);
3108 SvIVX(dstr) = SvIVX(sstr);
3111 if (SvTAINTED(sstr))
3122 sv_upgrade(dstr, SVt_NV);
3127 sv_upgrade(dstr, SVt_PVNV);
3130 SvNVX(dstr) = SvNVX(sstr);
3131 (void)SvNOK_only(dstr);
3132 if (SvTAINTED(sstr))
3140 sv_upgrade(dstr, SVt_RV);
3141 else if (dtype == SVt_PVGV &&
3142 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3145 if (GvIMPORTED(dstr) != GVf_IMPORTED
3146 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3148 GvIMPORTED_on(dstr);
3159 sv_upgrade(dstr, SVt_PV);
3162 if (dtype < SVt_PVIV)
3163 sv_upgrade(dstr, SVt_PVIV);
3166 if (dtype < SVt_PVNV)
3167 sv_upgrade(dstr, SVt_PVNV);
3174 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3175 PL_op_name[PL_op->op_type]);
3177 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3181 if (dtype <= SVt_PVGV) {
3183 if (dtype != SVt_PVGV) {
3184 char *name = GvNAME(sstr);
3185 STRLEN len = GvNAMELEN(sstr);
3186 sv_upgrade(dstr, SVt_PVGV);
3187 sv_magic(dstr, dstr, '*', Nullch, 0);
3188 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3189 GvNAME(dstr) = savepvn(name, len);
3190 GvNAMELEN(dstr) = len;
3191 SvFAKE_on(dstr); /* can coerce to non-glob */
3193 /* ahem, death to those who redefine active sort subs */
3194 else if (PL_curstackinfo->si_type == PERLSI_SORT
3195 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3196 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3198 (void)SvOK_off(dstr);
3199 GvINTRO_off(dstr); /* one-shot flag */
3201 GvGP(dstr) = gp_ref(GvGP(sstr));
3202 if (SvTAINTED(sstr))
3204 if (GvIMPORTED(dstr) != GVf_IMPORTED
3205 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3207 GvIMPORTED_on(dstr);
3215 if (SvGMAGICAL(sstr)) {
3217 if (SvTYPE(sstr) != stype) {
3218 stype = SvTYPE(sstr);
3219 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3223 if (stype == SVt_PVLV)
3224 (void)SvUPGRADE(dstr, SVt_PVNV);
3226 (void)SvUPGRADE(dstr, stype);
3229 sflags = SvFLAGS(sstr);
3231 if (sflags & SVf_ROK) {
3232 if (dtype >= SVt_PV) {
3233 if (dtype == SVt_PVGV) {
3234 SV *sref = SvREFCNT_inc(SvRV(sstr));
3236 int intro = GvINTRO(dstr);
3241 GvINTRO_off(dstr); /* one-shot flag */
3242 Newz(602,gp, 1, GP);
3243 GvGP(dstr) = gp_ref(gp);
3244 GvSV(dstr) = NEWSV(72,0);
3245 GvLINE(dstr) = CopLINE(PL_curcop);
3246 GvEGV(dstr) = (GV*)dstr;
3249 switch (SvTYPE(sref)) {
3252 SAVESPTR(GvAV(dstr));
3254 dref = (SV*)GvAV(dstr);
3255 GvAV(dstr) = (AV*)sref;
3256 if (!GvIMPORTED_AV(dstr)
3257 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3259 GvIMPORTED_AV_on(dstr);
3264 SAVESPTR(GvHV(dstr));
3266 dref = (SV*)GvHV(dstr);
3267 GvHV(dstr) = (HV*)sref;
3268 if (!GvIMPORTED_HV(dstr)
3269 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3271 GvIMPORTED_HV_on(dstr);
3276 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3277 SvREFCNT_dec(GvCV(dstr));
3278 GvCV(dstr) = Nullcv;
3279 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280 PL_sub_generation++;
3282 SAVESPTR(GvCV(dstr));
3285 dref = (SV*)GvCV(dstr);
3286 if (GvCV(dstr) != (CV*)sref) {
3287 CV* cv = GvCV(dstr);
3289 if (!GvCVGEN((GV*)dstr) &&
3290 (CvROOT(cv) || CvXSUB(cv)))
3293 /* ahem, death to those who redefine
3294 * active sort subs */
3295 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3296 PL_sortcop == CvSTART(cv))
3298 "Can't redefine active sort subroutine %s",
3299 GvENAME((GV*)dstr));
3300 /* Redefining a sub - warning is mandatory if
3301 it was a const and its value changed. */
3302 if (ckWARN(WARN_REDEFINE)
3304 && (!CvCONST((CV*)sref)
3305 || sv_cmp(cv_const_sv(cv),
3306 cv_const_sv((CV*)sref)))))
3308 Perl_warner(aTHX_ WARN_REDEFINE,
3310 ? "Constant subroutine %s redefined"
3311 : "Subroutine %s redefined",
3312 GvENAME((GV*)dstr));
3315 cv_ckproto(cv, (GV*)dstr,
3316 SvPOK(sref) ? SvPVX(sref) : Nullch);
3318 GvCV(dstr) = (CV*)sref;
3319 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3320 GvASSUMECV_on(dstr);
3321 PL_sub_generation++;
3323 if (!GvIMPORTED_CV(dstr)
3324 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3326 GvIMPORTED_CV_on(dstr);
3331 SAVESPTR(GvIOp(dstr));
3333 dref = (SV*)GvIOp(dstr);
3334 GvIOp(dstr) = (IO*)sref;
3338 SAVESPTR(GvFORM(dstr));
3340 dref = (SV*)GvFORM(dstr);
3341 GvFORM(dstr) = (CV*)sref;
3345 SAVESPTR(GvSV(dstr));
3347 dref = (SV*)GvSV(dstr);
3349 if (!GvIMPORTED_SV(dstr)
3350 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3352 GvIMPORTED_SV_on(dstr);
3360 if (SvTAINTED(sstr))
3365 (void)SvOOK_off(dstr); /* backoff */
3367 Safefree(SvPVX(dstr));
3368 SvLEN(dstr)=SvCUR(dstr)=0;
3371 (void)SvOK_off(dstr);
3372 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3374 if (sflags & SVp_NOK) {
3376 SvNVX(dstr) = SvNVX(sstr);
3378 if (sflags & SVp_IOK) {
3379 (void)SvIOK_on(dstr);
3380 SvIVX(dstr) = SvIVX(sstr);
3381 if (sflags & SVf_IVisUV)
3384 if (SvAMAGIC(sstr)) {
3388 else if (sflags & SVp_POK) {
3391 * Check to see if we can just swipe the string. If so, it's a
3392 * possible small lose on short strings, but a big win on long ones.
3393 * It might even be a win on short strings if SvPVX(dstr)
3394 * has to be allocated and SvPVX(sstr) has to be freed.
3397 if (SvTEMP(sstr) && /* slated for free anyway? */
3398 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3399 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3400 SvLEN(sstr) && /* and really is a string */
3401 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3403 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3405 SvFLAGS(dstr) &= ~SVf_OOK;
3406 Safefree(SvPVX(dstr) - SvIVX(dstr));
3408 else if (SvLEN(dstr))
3409 Safefree(SvPVX(dstr));
3411 (void)SvPOK_only(dstr);
3412 SvPV_set(dstr, SvPVX(sstr));
3413 SvLEN_set(dstr, SvLEN(sstr));
3414 SvCUR_set(dstr, SvCUR(sstr));
3417 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3418 SvPV_set(sstr, Nullch);
3423 else { /* have to copy actual string */
3424 STRLEN len = SvCUR(sstr);
3426 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3427 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3428 SvCUR_set(dstr, len);
3429 *SvEND(dstr) = '\0';
3430 (void)SvPOK_only(dstr);
3432 if ((sflags & SVf_UTF8) && !IN_BYTE)
3435 if (sflags & SVp_NOK) {
3437 SvNVX(dstr) = SvNVX(sstr);
3439 if (sflags & SVp_IOK) {
3440 (void)SvIOK_on(dstr);
3441 SvIVX(dstr) = SvIVX(sstr);
3442 if (sflags & SVf_IVisUV)
3446 else if (sflags & SVp_NOK) {
3447 SvNVX(dstr) = SvNVX(sstr);
3448 (void)SvNOK_only(dstr);
3449 if (sflags & SVf_IOK) {
3450 (void)SvIOK_on(dstr);
3451 SvIVX(dstr) = SvIVX(sstr);
3452 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3453 if (sflags & SVf_IVisUV)
3457 else if (sflags & SVp_IOK) {
3458 (void)SvIOK_only(dstr);
3459 SvIVX(dstr) = SvIVX(sstr);
3460 if (sflags & SVf_IVisUV)
3464 if (dtype == SVt_PVGV) {
3465 if (ckWARN(WARN_MISC))
3466 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3469 (void)SvOK_off(dstr);
3471 if (SvTAINTED(sstr))
3476 =for apidoc sv_setsv_mg
3478 Like C<sv_setsv>, but also handles 'set' magic.
3484 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3486 sv_setsv(dstr,sstr);
3491 =for apidoc sv_setpvn
3493 Copies a string into an SV. The C<len> parameter indicates the number of
3494 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3500 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3502 register char *dptr;
3504 /* len is STRLEN which is unsigned, need to copy to signed */
3508 SV_CHECK_THINKFIRST(sv);
3513 (void)SvUPGRADE(sv, SVt_PV);
3515 SvGROW(sv, len + 1);
3517 Move(ptr,dptr,len,char);
3520 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3525 =for apidoc sv_setpvn_mg
3527 Like C<sv_setpvn>, but also handles 'set' magic.
3533 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3535 sv_setpvn(sv,ptr,len);
3540 =for apidoc sv_setpv
3542 Copies a string into an SV. The string must be null-terminated. Does not
3543 handle 'set' magic. See C<sv_setpv_mg>.
3549 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3551 register STRLEN len;
3553 SV_CHECK_THINKFIRST(sv);
3559 (void)SvUPGRADE(sv, SVt_PV);
3561 SvGROW(sv, len + 1);
3562 Move(ptr,SvPVX(sv),len+1,char);
3564 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3569 =for apidoc sv_setpv_mg
3571 Like C<sv_setpv>, but also handles 'set' magic.
3577 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3584 =for apidoc sv_usepvn
3586 Tells an SV to use C<ptr> to find its string value. Normally the string is
3587 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3588 The C<ptr> should point to memory that was allocated by C<malloc>. The
3589 string length, C<len>, must be supplied. This function will realloc the
3590 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3591 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3592 See C<sv_usepvn_mg>.
3598 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3600 SV_CHECK_THINKFIRST(sv);
3601 (void)SvUPGRADE(sv, SVt_PV);
3606 (void)SvOOK_off(sv);
3607 if (SvPVX(sv) && SvLEN(sv))
3608 Safefree(SvPVX(sv));
3609 Renew(ptr, len+1, char);
3612 SvLEN_set(sv, len+1);
3614 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3619 =for apidoc sv_usepvn_mg
3621 Like C<sv_usepvn>, but also handles 'set' magic.
3627 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3629 sv_usepvn(sv,ptr,len);
3634 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3636 if (SvREADONLY(sv)) {
3638 char *pvx = SvPVX(sv);
3639 STRLEN len = SvCUR(sv);
3640 U32 hash = SvUVX(sv);
3641 SvGROW(sv, len + 1);
3642 Move(pvx,SvPVX(sv),len,char);
3646 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3648 else if (PL_curcop != &PL_compiling)
3649 Perl_croak(aTHX_ PL_no_modify);
3652 sv_unref_flags(sv, flags);
3653 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3658 Perl_sv_force_normal(pTHX_ register SV *sv)
3660 sv_force_normal_flags(sv, 0);
3666 Efficient removal of characters from the beginning of the string buffer.
3667 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3668 the string buffer. The C<ptr> becomes the first character of the adjusted
3675 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3679 register STRLEN delta;
3681 if (!ptr || !SvPOKp(sv))
3683 SV_CHECK_THINKFIRST(sv);
3684 if (SvTYPE(sv) < SVt_PVIV)
3685 sv_upgrade(sv,SVt_PVIV);
3688 if (!SvLEN(sv)) { /* make copy of shared string */
3689 char *pvx = SvPVX(sv);
3690 STRLEN len = SvCUR(sv);
3691 SvGROW(sv, len + 1);
3692 Move(pvx,SvPVX(sv),len,char);
3696 SvFLAGS(sv) |= SVf_OOK;
3698 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3699 delta = ptr - SvPVX(sv);
3707 =for apidoc sv_catpvn
3709 Concatenates the string onto the end of the string which is in the SV. The
3710 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3711 'set' magic. See C<sv_catpvn_mg>.
3717 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3722 junk = SvPV_force(sv, tlen);
3723 SvGROW(sv, tlen + len + 1);
3726 Move(ptr,SvPVX(sv)+tlen,len,char);
3729 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3734 =for apidoc sv_catpvn_mg
3736 Like C<sv_catpvn>, but also handles 'set' magic.
3742 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3744 sv_catpvn(sv,ptr,len);
3749 =for apidoc sv_catsv
3751 Concatenates the string from SV C<ssv> onto the end of the string in
3752 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3753 not 'set' magic. See C<sv_catsv_mg>.
3758 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3764 if ((spv = SvPV(sstr, slen))) {
3765 bool dutf8 = DO_UTF8(dstr);
3766 bool sutf8 = DO_UTF8(sstr);
3769 sv_catpvn(dstr,spv,slen);
3772 SV* cstr = newSVsv(sstr);
3776 sv_utf8_upgrade(cstr);
3777 cpv = SvPV(cstr,clen);
3778 sv_catpvn(dstr,cpv,clen);
3782 sv_utf8_upgrade(dstr);
3783 sv_catpvn(dstr,spv,slen);
3791 =for apidoc sv_catsv_mg
3793 Like C<sv_catsv>, but also handles 'set' magic.
3799 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3801 sv_catsv(dstr,sstr);
3806 =for apidoc sv_catpv
3808 Concatenates the string onto the end of the string which is in the SV.
3809 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3815 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3817 register STRLEN len;
3823 junk = SvPV_force(sv, tlen);
3825 SvGROW(sv, tlen + len + 1);
3828 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3830 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3835 =for apidoc sv_catpv_mg
3837 Like C<sv_catpv>, but also handles 'set' magic.
3843 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3850 Perl_newSV(pTHX_ STRLEN len)
3856 sv_upgrade(sv, SVt_PV);
3857 SvGROW(sv, len + 1);
3862 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3865 =for apidoc sv_magic
3867 Adds magic to an SV.
3873 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3877 if (SvREADONLY(sv)) {
3878 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3879 Perl_croak(aTHX_ PL_no_modify);
3881 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3882 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3889 (void)SvUPGRADE(sv, SVt_PVMG);
3891 Newz(702,mg, 1, MAGIC);
3892 mg->mg_moremagic = SvMAGIC(sv);
3895 if (!obj || obj == sv || how == '#' || how == 'r')
3898 mg->mg_obj = SvREFCNT_inc(obj);
3899 mg->mg_flags |= MGf_REFCOUNTED;
3902 mg->mg_len = namlen;
3905 mg->mg_ptr = savepvn(name, namlen);
3906 else if (namlen == HEf_SVKEY)
3907 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3911 mg->mg_virtual = &PL_vtbl_sv;
3914 mg->mg_virtual = &PL_vtbl_amagic;
3917 mg->mg_virtual = &PL_vtbl_amagicelem;
3923 mg->mg_virtual = &PL_vtbl_bm;
3926 mg->mg_virtual = &PL_vtbl_regdata;
3929 mg->mg_virtual = &PL_vtbl_regdatum;
3932 mg->mg_virtual = &PL_vtbl_env;
3935 mg->mg_virtual = &PL_vtbl_fm;
3938 mg->mg_virtual = &PL_vtbl_envelem;
3941 mg->mg_virtual = &PL_vtbl_mglob;
3944 mg->mg_virtual = &PL_vtbl_isa;
3947 mg->mg_virtual = &PL_vtbl_isaelem;
3950 mg->mg_virtual = &PL_vtbl_nkeys;
3957 mg->mg_virtual = &PL_vtbl_dbline;
3961 mg->mg_virtual = &PL_vtbl_mutex;
3963 #endif /* USE_THREADS */
3964 #ifdef USE_LOCALE_COLLATE
3966 mg->mg_virtual = &PL_vtbl_collxfrm;
3968 #endif /* USE_LOCALE_COLLATE */
3970 mg->mg_virtual = &PL_vtbl_pack;
3974 mg->mg_virtual = &PL_vtbl_packelem;
3977 mg->mg_virtual = &PL_vtbl_regexp;
3980 mg->mg_virtual = &PL_vtbl_sig;
3983 mg->mg_virtual = &PL_vtbl_sigelem;
3986 mg->mg_virtual = &PL_vtbl_taint;
3990 mg->mg_virtual = &PL_vtbl_uvar;
3993 mg->mg_virtual = &PL_vtbl_vec;
3996 mg->mg_virtual = &PL_vtbl_substr;
3999 mg->mg_virtual = &PL_vtbl_defelem;
4002 mg->mg_virtual = &PL_vtbl_glob;
4005 mg->mg_virtual = &PL_vtbl_arylen;
4008 mg->mg_virtual = &PL_vtbl_pos;
4011 mg->mg_virtual = &PL_vtbl_backref;
4013 case '~': /* Reserved for use by extensions not perl internals. */
4014 /* Useful for attaching extension internal data to perl vars. */
4015 /* Note that multiple extensions may clash if magical scalars */
4016 /* etc holding private data from one are passed to another. */
4020 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4024 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4028 =for apidoc sv_unmagic
4030 Removes magic from an SV.
4036 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4040 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4043 for (mg = *mgp; mg; mg = *mgp) {
4044 if (mg->mg_type == type) {
4045 MGVTBL* vtbl = mg->mg_virtual;
4046 *mgp = mg->mg_moremagic;
4047 if (vtbl && vtbl->svt_free)
4048 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4049 if (mg->mg_ptr && mg->mg_type != 'g')
4050 if (mg->mg_len >= 0)
4051 Safefree(mg->mg_ptr);
4052 else if (mg->mg_len == HEf_SVKEY)
4053 SvREFCNT_dec((SV*)mg->mg_ptr);
4054 if (mg->mg_flags & MGf_REFCOUNTED)
4055 SvREFCNT_dec(mg->mg_obj);
4059 mgp = &mg->mg_moremagic;
4063 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4070 =for apidoc sv_rvweaken
4078 Perl_sv_rvweaken(pTHX_ SV *sv)
4081 if (!SvOK(sv)) /* let undefs pass */
4084 Perl_croak(aTHX_ "Can't weaken a nonreference");
4085 else if (SvWEAKREF(sv)) {
4086 if (ckWARN(WARN_MISC))
4087 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4091 sv_add_backref(tsv, sv);
4098 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4102 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4103 av = (AV*)mg->mg_obj;
4106 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4107 SvREFCNT_dec(av); /* for sv_magic */
4113 S_sv_del_backref(pTHX_ SV *sv)
4120 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4121 Perl_croak(aTHX_ "panic: del_backref");
4122 av = (AV *)mg->mg_obj;
4127 svp[i] = &PL_sv_undef; /* XXX */
4134 =for apidoc sv_insert
4136 Inserts a string at the specified offset/length within the SV. Similar to
4137 the Perl substr() function.
4143 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4147 register char *midend;
4148 register char *bigend;
4154 Perl_croak(aTHX_ "Can't modify non-existent substring");
4155 SvPV_force(bigstr, curlen);
4156 (void)SvPOK_only_UTF8(bigstr);
4157 if (offset + len > curlen) {
4158 SvGROW(bigstr, offset+len+1);
4159 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4160 SvCUR_set(bigstr, offset+len);
4164 i = littlelen - len;
4165 if (i > 0) { /* string might grow */
4166 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4167 mid = big + offset + len;
4168 midend = bigend = big + SvCUR(bigstr);
4171 while (midend > mid) /* shove everything down */
4172 *--bigend = *--midend;
4173 Move(little,big+offset,littlelen,char);
4179 Move(little,SvPVX(bigstr)+offset,len,char);
4184 big = SvPVX(bigstr);
4187 bigend = big + SvCUR(bigstr);
4189 if (midend > bigend)
4190 Perl_croak(aTHX_ "panic: sv_insert");
4192 if (mid - big > bigend - midend) { /* faster to shorten from end */
4194 Move(little, mid, littlelen,char);
4197 i = bigend - midend;
4199 Move(midend, mid, i,char);
4203 SvCUR_set(bigstr, mid - big);
4206 else if ((i = mid - big)) { /* faster from front */
4207 midend -= littlelen;
4209 sv_chop(bigstr,midend-i);
4214 Move(little, mid, littlelen,char);
4216 else if (littlelen) {
4217 midend -= littlelen;
4218 sv_chop(bigstr,midend);
4219 Move(little,midend,littlelen,char);
4222 sv_chop(bigstr,midend);
4228 =for apidoc sv_replace
4230 Make the first argument a copy of the second, then delete the original.
4236 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4238 U32 refcnt = SvREFCNT(sv);
4239 SV_CHECK_THINKFIRST(sv);
4240 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4241 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4242 if (SvMAGICAL(sv)) {
4246 sv_upgrade(nsv, SVt_PVMG);
4247 SvMAGIC(nsv) = SvMAGIC(sv);
4248 SvFLAGS(nsv) |= SvMAGICAL(sv);
4254 assert(!SvREFCNT(sv));
4255 StructCopy(nsv,sv,SV);
4256 SvREFCNT(sv) = refcnt;
4257 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4262 =for apidoc sv_clear
4264 Clear an SV, making it empty. Does not free the memory used by the SV
4271 Perl_sv_clear(pTHX_ register SV *sv)
4275 assert(SvREFCNT(sv) == 0);
4278 if (PL_defstash) { /* Still have a symbol table? */
4283 Zero(&tmpref, 1, SV);
4284 sv_upgrade(&tmpref, SVt_RV);
4286 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4287 SvREFCNT(&tmpref) = 1;
4290 stash = SvSTASH(sv);
4291 destructor = StashHANDLER(stash,DESTROY);
4294 PUSHSTACKi(PERLSI_DESTROY);
4295 SvRV(&tmpref) = SvREFCNT_inc(sv);
4300 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4306 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4308 del_XRV(SvANY(&tmpref));
4311 if (PL_in_clean_objs)
4312 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4314 /* DESTROY gave object new lease on life */
4320 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4321 SvOBJECT_off(sv); /* Curse the object. */
4322 if (SvTYPE(sv) != SVt_PVIO)
4323 --PL_sv_objcount; /* XXX Might want something more general */
4326 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4329 switch (SvTYPE(sv)) {
4332 IoIFP(sv) != PerlIO_stdin() &&
4333 IoIFP(sv) != PerlIO_stdout() &&
4334 IoIFP(sv) != PerlIO_stderr())
4336 io_close((IO*)sv, FALSE);
4338 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4339 PerlDir_close(IoDIRP(sv));
4340 IoDIRP(sv) = (DIR*)NULL;
4341 Safefree(IoTOP_NAME(sv));
4342 Safefree(IoFMT_NAME(sv));
4343 Safefree(IoBOTTOM_NAME(sv));
4358 SvREFCNT_dec(LvTARG(sv));
4362 Safefree(GvNAME(sv));
4363 /* cannot decrease stash refcount yet, as we might recursively delete
4364 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4365 of stash until current sv is completely gone.
4366 -- JohnPC, 27 Mar 1998 */
4367 stash = GvSTASH(sv);
4373 (void)SvOOK_off(sv);
4381 SvREFCNT_dec(SvRV(sv));
4383 else if (SvPVX(sv) && SvLEN(sv))
4384 Safefree(SvPVX(sv));
4385 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4386 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4398 switch (SvTYPE(sv)) {
4414 del_XPVIV(SvANY(sv));
4417 del_XPVNV(SvANY(sv));
4420 del_XPVMG(SvANY(sv));
4423 del_XPVLV(SvANY(sv));
4426 del_XPVAV(SvANY(sv));
4429 del_XPVHV(SvANY(sv));
4432 del_XPVCV(SvANY(sv));
4435 del_XPVGV(SvANY(sv));
4436 /* code duplication for increased performance. */
4437 SvFLAGS(sv) &= SVf_BREAK;
4438 SvFLAGS(sv) |= SVTYPEMASK;
4439 /* decrease refcount of the stash that owns this GV, if any */
4441 SvREFCNT_dec(stash);
4442 return; /* not break, SvFLAGS reset already happened */
4444 del_XPVBM(SvANY(sv));
4447 del_XPVFM(SvANY(sv));
4450 del_XPVIO(SvANY(sv));
4453 SvFLAGS(sv) &= SVf_BREAK;
4454 SvFLAGS(sv) |= SVTYPEMASK;
4458 Perl_sv_newref(pTHX_ SV *sv)
4461 ATOMIC_INC(SvREFCNT(sv));
4468 Free the memory used by an SV.
4474 Perl_sv_free(pTHX_ SV *sv)
4476 int refcount_is_zero;
4480 if (SvREFCNT(sv) == 0) {
4481 if (SvFLAGS(sv) & SVf_BREAK)
4483 if (PL_in_clean_all) /* All is fair */
4485 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4486 /* make sure SvREFCNT(sv)==0 happens very seldom */
4487 SvREFCNT(sv) = (~(U32)0)/2;
4490 if (ckWARN_d(WARN_INTERNAL))
4491 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4494 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4495 if (!refcount_is_zero)
4499 if (ckWARN_d(WARN_DEBUGGING))
4500 Perl_warner(aTHX_ WARN_DEBUGGING,
4501 "Attempt to free temp prematurely: SV 0x%"UVxf,
4506 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4507 /* make sure SvREFCNT(sv)==0 happens very seldom */
4508 SvREFCNT(sv) = (~(U32)0)/2;
4519 Returns the length of the string in the SV. See also C<SvCUR>.
4525 Perl_sv_len(pTHX_ register SV *sv)
4534 len = mg_length(sv);
4536 junk = SvPV(sv, len);
4541 =for apidoc sv_len_utf8
4543 Returns the number of characters in the string in an SV, counting wide
4544 UTF8 bytes as a single character.
4550 Perl_sv_len_utf8(pTHX_ register SV *sv)
4556 return mg_length(sv);
4560 U8 *s = (U8*)SvPV(sv, len);
4562 return Perl_utf8_length(aTHX_ s, s + len);
4567 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4572 I32 uoffset = *offsetp;
4578 start = s = (U8*)SvPV(sv, len);
4580 while (s < send && uoffset--)
4584 *offsetp = s - start;
4588 while (s < send && ulen--)
4598 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4607 s = (U8*)SvPV(sv, len);
4609 Perl_croak(aTHX_ "panic: bad byte offset");
4610 send = s + *offsetp;
4617 if (ckWARN_d(WARN_UTF8))
4618 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4628 Returns a boolean indicating whether the strings in the two SVs are
4635 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4642 bool pv1tmp = FALSE;
4643 bool pv2tmp = FALSE;
4650 pv1 = SvPV(sv1, cur1);
4657 pv2 = SvPV(sv2, cur2);
4659 /* do not utf8ize the comparands as a side-effect */
4660 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4661 if (PL_hints & HINT_UTF8_DISTINCT)
4665 (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
4673 (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
4683 eq = memEQ(pv1, pv2, cur1);
4696 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4697 string in C<sv1> is less than, equal to, or greater than the string in
4704 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4709 bool pv1tmp = FALSE;
4710 bool pv2tmp = FALSE;
4717 pv1 = SvPV(sv1, cur1);
4724 pv2 = SvPV(sv2, cur2);
4726 /* do not utf8ize the comparands as a side-effect */
4727 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4728 if (PL_hints & HINT_UTF8_DISTINCT)
4729 return SvUTF8(sv1) ? 1 : -1;
4732 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4736 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4742 cmp = cur2 ? -1 : 0;
4746 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4749 cmp = retval < 0 ? -1 : 1;
4750 } else if (cur1 == cur2) {
4753 cmp = cur1 < cur2 ? -1 : 1;
4766 =for apidoc sv_cmp_locale
4768 Compares the strings in two SVs in a locale-aware manner. See
4775 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4777 #ifdef USE_LOCALE_COLLATE
4783 if (PL_collation_standard)
4787 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4789 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4791 if (!pv1 || !len1) {
4802 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4805 return retval < 0 ? -1 : 1;
4808 * When the result of collation is equality, that doesn't mean
4809 * that there are no differences -- some locales exclude some
4810 * characters from consideration. So to avoid false equalities,
4811 * we use the raw string as a tiebreaker.
4817 #endif /* USE_LOCALE_COLLATE */
4819 return sv_cmp(sv1, sv2);
4822 #ifdef USE_LOCALE_COLLATE
4824 * Any scalar variable may carry an 'o' magic that contains the
4825 * scalar data of the variable transformed to such a format that
4826 * a normal memory comparison can be used to compare the data
4827 * according to the locale settings.
4830 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4834 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4835 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4840 Safefree(mg->mg_ptr);
4842 if ((xf = mem_collxfrm(s, len, &xlen))) {
4843 if (SvREADONLY(sv)) {
4846 return xf + sizeof(PL_collation_ix);
4849 sv_magic(sv, 0, 'o', 0, 0);
4850 mg = mg_find(sv, 'o');
4863 if (mg && mg->mg_ptr) {
4865 return mg->mg_ptr + sizeof(PL_collation_ix);
4873 #endif /* USE_LOCALE_COLLATE */
4878 Get a line from the filehandle and store it into the SV, optionally
4879 appending to the currently-stored string.
4885 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4889 register STDCHAR rslast;
4890 register STDCHAR *bp;
4894 SV_CHECK_THINKFIRST(sv);
4895 (void)SvUPGRADE(sv, SVt_PV);
4899 if (RsSNARF(PL_rs)) {
4903 else if (RsRECORD(PL_rs)) {
4904 I32 recsize, bytesread;
4907 /* Grab the size of the record we're getting */
4908 recsize = SvIV(SvRV(PL_rs));
4909 (void)SvPOK_only(sv); /* Validate pointer */
4910 buffer = SvGROW(sv, recsize + 1);
4913 /* VMS wants read instead of fread, because fread doesn't respect */
4914 /* RMS record boundaries. This is not necessarily a good thing to be */
4915 /* doing, but we've got no other real choice */
4916 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4918 bytesread = PerlIO_read(fp, buffer, recsize);
4920 SvCUR_set(sv, bytesread);
4921 buffer[bytesread] = '\0';
4922 if (PerlIO_isutf8(fp))
4926 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4928 else if (RsPARA(PL_rs)) {
4933 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4934 if (PerlIO_isutf8(fp)) {
4935 rsptr = SvPVutf8(PL_rs, rslen);
4938 if (SvUTF8(PL_rs)) {
4939 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4940 Perl_croak(aTHX_ "Wide character in $/");
4943 rsptr = SvPV(PL_rs, rslen);
4947 rslast = rslen ? rsptr[rslen - 1] : '\0';
4949 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4950 do { /* to make sure file boundaries work right */
4953 i = PerlIO_getc(fp);
4957 PerlIO_ungetc(fp,i);
4963 /* See if we know enough about I/O mechanism to cheat it ! */
4965 /* This used to be #ifdef test - it is made run-time test for ease
4966 of abstracting out stdio interface. One call should be cheap
4967 enough here - and may even be a macro allowing compile
4971 if (PerlIO_fast_gets(fp)) {
4974 * We're going to steal some values from the stdio struct
4975 * and put EVERYTHING in the innermost loop into registers.
4977 register STDCHAR *ptr;
4981 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4982 /* An ungetc()d char is handled separately from the regular
4983 * buffer, so we getc() it back out and stuff it in the buffer.
4985 i = PerlIO_getc(fp);
4986 if (i == EOF) return 0;
4987 *(--((*fp)->_ptr)) = (unsigned char) i;
4991 /* Here is some breathtakingly efficient cheating */
4993 cnt = PerlIO_get_cnt(fp); /* get count into register */
4994 (void)SvPOK_only(sv); /* validate pointer */
4995 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4996 if (cnt > 80 && SvLEN(sv) > append) {
4997 shortbuffered = cnt - SvLEN(sv) + append + 1;
4998 cnt -= shortbuffered;
5002 /* remember that cnt can be negative */
5003 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5008 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5009 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5010 DEBUG_P(PerlIO_printf(Perl_debug_log,
5011 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5012 DEBUG_P(PerlIO_printf(Perl_debug_log,
5013 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5014 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5015 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5020 while (cnt > 0) { /* this | eat */
5022 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5023 goto thats_all_folks; /* screams | sed :-) */
5027 Copy(ptr, bp, cnt, char); /* this | eat */
5028 bp += cnt; /* screams | dust */
5029 ptr += cnt; /* louder | sed :-) */
5034 if (shortbuffered) { /* oh well, must extend */
5035 cnt = shortbuffered;
5037 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5039 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5040 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5044 DEBUG_P(PerlIO_printf(Perl_debug_log,
5045 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5046 PTR2UV(ptr),(long)cnt));
5047 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5048 DEBUG_P(PerlIO_printf(Perl_debug_log,
5049 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5050 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5051 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5052 /* This used to call 'filbuf' in stdio form, but as that behaves like
5053 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5054 another abstraction. */
5055 i = PerlIO_getc(fp); /* get more characters */
5056 DEBUG_P(PerlIO_printf(Perl_debug_log,
5057 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5058 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5059 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5060 cnt = PerlIO_get_cnt(fp);
5061 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5062 DEBUG_P(PerlIO_printf(Perl_debug_log,
5063 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5065 if (i == EOF) /* all done for ever? */
5066 goto thats_really_all_folks;
5068 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5070 SvGROW(sv, bpx + cnt + 2);
5071 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5073 *bp++ = i; /* store character from PerlIO_getc */
5075 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5076 goto thats_all_folks;
5080 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5081 memNE((char*)bp - rslen, rsptr, rslen))
5082 goto screamer; /* go back to the fray */
5083 thats_really_all_folks:
5085 cnt += shortbuffered;
5086 DEBUG_P(PerlIO_printf(Perl_debug_log,
5087 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5088 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5089 DEBUG_P(PerlIO_printf(Perl_debug_log,
5090 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5091 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5092 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5094 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5095 DEBUG_P(PerlIO_printf(Perl_debug_log,
5096 "Screamer: done, len=%ld, string=|%.*s|\n",
5097 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5102 /*The big, slow, and stupid way */
5105 /* Need to work around EPOC SDK features */
5106 /* On WINS: MS VC5 generates calls to _chkstk, */
5107 /* if a `large' stack frame is allocated */
5108 /* gcc on MARM does not generate calls like these */
5114 register STDCHAR *bpe = buf + sizeof(buf);
5116 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5117 ; /* keep reading */
5121 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5122 /* Accomodate broken VAXC compiler, which applies U8 cast to
5123 * both args of ?: operator, causing EOF to change into 255
5125 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5129 sv_catpvn(sv, (char *) buf, cnt);
5131 sv_setpvn(sv, (char *) buf, cnt);
5133 if (i != EOF && /* joy */
5135 SvCUR(sv) < rslen ||
5136 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5140 * If we're reading from a TTY and we get a short read,
5141 * indicating that the user hit his EOF character, we need
5142 * to notice it now, because if we try to read from the TTY
5143 * again, the EOF condition will disappear.
5145 * The comparison of cnt to sizeof(buf) is an optimization
5146 * that prevents unnecessary calls to feof().
5150 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5155 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5156 while (i != EOF) { /* to make sure file boundaries work right */
5157 i = PerlIO_getc(fp);
5159 PerlIO_ungetc(fp,i);
5165 if (PerlIO_isutf8(fp))
5170 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5177 Auto-increment of the value in the SV.
5183 Perl_sv_inc(pTHX_ register SV *sv)
5192 if (SvTHINKFIRST(sv)) {
5193 if (SvREADONLY(sv)) {
5194 if (PL_curcop != &PL_compiling)
5195 Perl_croak(aTHX_ PL_no_modify);
5199 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5201 i = PTR2IV(SvRV(sv));
5206 flags = SvFLAGS(sv);
5207 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5208 /* It's (privately or publicly) a float, but not tested as an
5209 integer, so test it to see. */
5211 flags = SvFLAGS(sv);
5213 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5214 /* It's publicly an integer, or privately an integer-not-float */
5217 if (SvUVX(sv) == UV_MAX)
5218 sv_setnv(sv, (NV)UV_MAX + 1.0);
5220 (void)SvIOK_only_UV(sv);
5223 if (SvIVX(sv) == IV_MAX)
5224 sv_setuv(sv, (UV)IV_MAX + 1);
5226 (void)SvIOK_only(sv);
5232 if (flags & SVp_NOK) {
5233 (void)SvNOK_only(sv);
5238 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5239 if ((flags & SVTYPEMASK) < SVt_PVIV)
5240 sv_upgrade(sv, SVt_IV);
5241 (void)SvIOK_only(sv);
5246 while (isALPHA(*d)) d++;
5247 while (isDIGIT(*d)) d++;
5249 #ifdef PERL_PRESERVE_IVUV
5250 /* Got to punt this an an integer if needs be, but we don't issue
5251 warnings. Probably ought to make the sv_iv_please() that does
5252 the conversion if possible, and silently. */
5253 I32 numtype = looks_like_number(sv);
5254 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5255 /* Need to try really hard to see if it's an integer.
5256 9.22337203685478e+18 is an integer.
5257 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5258 so $a="9.22337203685478e+18"; $a+0; $a++
5259 needs to be the same as $a="9.22337203685478e+18"; $a++
5266 /* sv_2iv *should* have made this an NV */
5267 if (flags & SVp_NOK) {
5268 (void)SvNOK_only(sv);
5272 /* I don't think we can get here. Maybe I should assert this
5273 And if we do get here I suspect that sv_setnv will croak. NWC
5275 #if defined(USE_LONG_DOUBLE)
5276 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",
5277 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5279 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5280 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5283 #endif /* PERL_PRESERVE_IVUV */
5284 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5288 while (d >= SvPVX(sv)) {
5296 /* MKS: The original code here died if letters weren't consecutive.
5297 * at least it didn't have to worry about non-C locales. The
5298 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5299 * arranged in order (although not consecutively) and that only
5300 * [A-Za-z] are accepted by isALPHA in the C locale.
5302 if (*d != 'z' && *d != 'Z') {
5303 do { ++*d; } while (!isALPHA(*d));
5306 *(d--) -= 'z' - 'a';
5311 *(d--) -= 'z' - 'a' + 1;
5315 /* oh,oh, the number grew */
5316 SvGROW(sv, SvCUR(sv) + 2);
5318 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5329 Auto-decrement of the value in the SV.
5335 Perl_sv_dec(pTHX_ register SV *sv)
5343 if (SvTHINKFIRST(sv)) {
5344 if (SvREADONLY(sv)) {
5345 if (PL_curcop != &PL_compiling)
5346 Perl_croak(aTHX_ PL_no_modify);
5350 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5352 i = PTR2IV(SvRV(sv));
5357 /* Unlike sv_inc we don't have to worry about string-never-numbers
5358 and keeping them magic. But we mustn't warn on punting */
5359 flags = SvFLAGS(sv);
5360 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5361 /* It's publicly an integer, or privately an integer-not-float */
5364 if (SvUVX(sv) == 0) {
5365 (void)SvIOK_only(sv);
5369 (void)SvIOK_only_UV(sv);
5373 if (SvIVX(sv) == IV_MIN)
5374 sv_setnv(sv, (NV)IV_MIN - 1.0);
5376 (void)SvIOK_only(sv);
5382 if (flags & SVp_NOK) {
5384 (void)SvNOK_only(sv);
5387 if (!(flags & SVp_POK)) {
5388 if ((flags & SVTYPEMASK) < SVt_PVNV)
5389 sv_upgrade(sv, SVt_NV);
5391 (void)SvNOK_only(sv);
5394 #ifdef PERL_PRESERVE_IVUV
5396 I32 numtype = looks_like_number(sv);
5397 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5398 /* Need to try really hard to see if it's an integer.
5399 9.22337203685478e+18 is an integer.
5400 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5401 so $a="9.22337203685478e+18"; $a+0; $a--
5402 needs to be the same as $a="9.22337203685478e+18"; $a--
5409 /* sv_2iv *should* have made this an NV */
5410 if (flags & SVp_NOK) {
5411 (void)SvNOK_only(sv);
5415 /* I don't think we can get here. Maybe I should assert this
5416 And if we do get here I suspect that sv_setnv will croak. NWC
5418 #if defined(USE_LONG_DOUBLE)
5419 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",
5420 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5422 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5423 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5427 #endif /* PERL_PRESERVE_IVUV */
5428 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5432 =for apidoc sv_mortalcopy
5434 Creates a new SV which is a copy of the original SV. The new SV is marked
5440 /* Make a string that will exist for the duration of the expression
5441 * evaluation. Actually, it may have to last longer than that, but
5442 * hopefully we won't free it until it has been assigned to a
5443 * permanent location. */
5446 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5451 sv_setsv(sv,oldstr);
5453 PL_tmps_stack[++PL_tmps_ix] = sv;
5459 =for apidoc sv_newmortal
5461 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5467 Perl_sv_newmortal(pTHX)
5472 SvFLAGS(sv) = SVs_TEMP;
5474 PL_tmps_stack[++PL_tmps_ix] = sv;
5479 =for apidoc sv_2mortal
5481 Marks an SV as mortal. The SV will be destroyed when the current context
5487 /* same thing without the copying */
5490 Perl_sv_2mortal(pTHX_ register SV *sv)
5494 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5497 PL_tmps_stack[++PL_tmps_ix] = sv;
5505 Creates a new SV and copies a string into it. The reference count for the
5506 SV is set to 1. If C<len> is zero, Perl will compute the length using
5507 strlen(). For efficiency, consider using C<newSVpvn> instead.
5513 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5520 sv_setpvn(sv,s,len);
5525 =for apidoc newSVpvn
5527 Creates a new SV and copies a string into it. The reference count for the
5528 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5529 string. You are responsible for ensuring that the source string is at least
5536 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5541 sv_setpvn(sv,s,len);
5546 =for apidoc newSVpvn_share
5548 Creates a new SV and populates it with a string from
5549 the string table. Turns on READONLY and FAKE.
5550 The idea here is that as string table is used for shared hash
5551 keys these strings will have SvPVX == HeKEY and hash lookup
5552 will avoid string compare.
5558 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5561 bool is_utf8 = FALSE;
5567 PERL_HASH(hash, src, len);
5569 sv_upgrade(sv, SVt_PVIV);
5570 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5582 #if defined(PERL_IMPLICIT_CONTEXT)
5584 Perl_newSVpvf_nocontext(const char* pat, ...)
5589 va_start(args, pat);
5590 sv = vnewSVpvf(pat, &args);
5597 =for apidoc newSVpvf
5599 Creates a new SV an initialize it with the string formatted like
5606 Perl_newSVpvf(pTHX_ const char* pat, ...)
5610 va_start(args, pat);
5611 sv = vnewSVpvf(pat, &args);
5617 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5621 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5628 Creates a new SV and copies a floating point value into it.
5629 The reference count for the SV is set to 1.
5635 Perl_newSVnv(pTHX_ NV n)
5647 Creates a new SV and copies an integer into it. The reference count for the
5654 Perl_newSViv(pTHX_ IV i)
5666 Creates a new SV and copies an unsigned integer into it.
5667 The reference count for the SV is set to 1.
5673 Perl_newSVuv(pTHX_ UV u)
5683 =for apidoc newRV_noinc
5685 Creates an RV wrapper for an SV. The reference count for the original
5686 SV is B<not> incremented.
5692 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5697 sv_upgrade(sv, SVt_RV);
5704 /* newRV_inc is #defined to newRV in sv.h */
5706 Perl_newRV(pTHX_ SV *tmpRef)
5708 return newRV_noinc(SvREFCNT_inc(tmpRef));
5714 Creates a new SV which is an exact duplicate of the original SV.
5719 /* make an exact duplicate of old */
5722 Perl_newSVsv(pTHX_ register SV *old)
5728 if (SvTYPE(old) == SVTYPEMASK) {
5729 if (ckWARN_d(WARN_INTERNAL))
5730 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5745 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5753 char todo[PERL_UCHAR_MAX+1];
5758 if (!*s) { /* reset ?? searches */
5759 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5760 pm->op_pmdynflags &= ~PMdf_USED;
5765 /* reset variables */
5767 if (!HvARRAY(stash))
5770 Zero(todo, 256, char);
5772 i = (unsigned char)*s;
5776 max = (unsigned char)*s++;
5777 for ( ; i <= max; i++) {
5780 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5781 for (entry = HvARRAY(stash)[i];
5783 entry = HeNEXT(entry))
5785 if (!todo[(U8)*HeKEY(entry)])
5787 gv = (GV*)HeVAL(entry);
5789 if (SvTHINKFIRST(sv)) {
5790 if (!SvREADONLY(sv) && SvROK(sv))
5795 if (SvTYPE(sv) >= SVt_PV) {
5797 if (SvPVX(sv) != Nullch)
5804 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5806 #ifdef USE_ENVIRON_ARRAY
5808 environ[0] = Nullch;
5817 Perl_sv_2io(pTHX_ SV *sv)
5823 switch (SvTYPE(sv)) {
5831 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5835 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5837 return sv_2io(SvRV(sv));
5838 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5844 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5851 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5858 return *gvp = Nullgv, Nullcv;
5859 switch (SvTYPE(sv)) {
5878 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5879 tryAMAGICunDEREF(to_cv);
5882 if (SvTYPE(sv) == SVt_PVCV) {
5891 Perl_croak(aTHX_ "Not a subroutine reference");
5896 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5902 if (lref && !GvCVu(gv)) {
5905 tmpsv = NEWSV(704,0);
5906 gv_efullname3(tmpsv, gv, Nullch);
5907 /* XXX this is probably not what they think they're getting.
5908 * It has the same effect as "sub name;", i.e. just a forward
5910 newSUB(start_subparse(FALSE, 0),
5911 newSVOP(OP_CONST, 0, tmpsv),
5916 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5925 Returns true if the SV has a true value by Perl's rules.
5931 Perl_sv_true(pTHX_ register SV *sv)
5937 if ((tXpv = (XPV*)SvANY(sv)) &&
5938 (tXpv->xpv_cur > 1 ||
5939 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5946 return SvIVX(sv) != 0;
5949 return SvNVX(sv) != 0.0;
5951 return sv_2bool(sv);
5957 Perl_sv_iv(pTHX_ register SV *sv)
5961 return (IV)SvUVX(sv);
5968 Perl_sv_uv(pTHX_ register SV *sv)
5973 return (UV)SvIVX(sv);
5979 Perl_sv_nv(pTHX_ register SV *sv)
5987 Perl_sv_pv(pTHX_ SV *sv)
5994 return sv_2pv(sv, &n_a);
5998 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6004 return sv_2pv(sv, lp);
6008 =for apidoc sv_pvn_force
6010 Get a sensible string out of the SV somehow.
6016 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6020 if (SvTHINKFIRST(sv) && !SvROK(sv))
6021 sv_force_normal(sv);
6027 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6028 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6029 PL_op_name[PL_op->op_type]);
6033 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6038 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6039 SvGROW(sv, len + 1);
6040 Move(s,SvPVX(sv),len,char);
6045 SvPOK_on(sv); /* validate pointer */
6047 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6048 PTR2UV(sv),SvPVX(sv)));
6055 Perl_sv_pvbyte(pTHX_ SV *sv)
6061 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6063 return sv_pvn(sv,lp);
6067 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6069 return sv_pvn_force(sv,lp);
6073 Perl_sv_pvutf8(pTHX_ SV *sv)
6075 sv_utf8_upgrade(sv);
6080 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6082 sv_utf8_upgrade(sv);
6083 return sv_pvn(sv,lp);
6087 =for apidoc sv_pvutf8n_force
6089 Get a sensible UTF8-encoded string out of the SV somehow. See
6096 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6098 sv_utf8_upgrade(sv);
6099 return sv_pvn_force(sv,lp);
6103 =for apidoc sv_reftype
6105 Returns a string describing what the SV is a reference to.
6111 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6113 if (ob && SvOBJECT(sv))
6114 return HvNAME(SvSTASH(sv));
6116 switch (SvTYPE(sv)) {
6130 case SVt_PVLV: return "LVALUE";
6131 case SVt_PVAV: return "ARRAY";
6132 case SVt_PVHV: return "HASH";
6133 case SVt_PVCV: return "CODE";
6134 case SVt_PVGV: return "GLOB";
6135 case SVt_PVFM: return "FORMAT";
6136 case SVt_PVIO: return "IO";
6137 default: return "UNKNOWN";
6143 =for apidoc sv_isobject
6145 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6146 object. If the SV is not an RV, or if the object is not blessed, then this
6153 Perl_sv_isobject(pTHX_ SV *sv)
6170 Returns a boolean indicating whether the SV is blessed into the specified
6171 class. This does not check for subtypes; use C<sv_derived_from> to verify
6172 an inheritance relationship.
6178 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6190 return strEQ(HvNAME(SvSTASH(sv)), name);
6196 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6197 it will be upgraded to one. If C<classname> is non-null then the new SV will
6198 be blessed in the specified package. The new SV is returned and its
6199 reference count is 1.
6205 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6211 SV_CHECK_THINKFIRST(rv);
6214 if (SvTYPE(rv) >= SVt_PVMG) {
6215 U32 refcnt = SvREFCNT(rv);
6219 SvREFCNT(rv) = refcnt;
6222 if (SvTYPE(rv) < SVt_RV)
6223 sv_upgrade(rv, SVt_RV);
6224 else if (SvTYPE(rv) > SVt_RV) {
6225 (void)SvOOK_off(rv);
6226 if (SvPVX(rv) && SvLEN(rv))
6227 Safefree(SvPVX(rv));
6237 HV* stash = gv_stashpv(classname, TRUE);
6238 (void)sv_bless(rv, stash);
6244 =for apidoc sv_setref_pv
6246 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6247 argument will be upgraded to an RV. That RV will be modified to point to
6248 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6249 into the SV. The C<classname> argument indicates the package for the
6250 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6251 will be returned and will have a reference count of 1.
6253 Do not use with other Perl types such as HV, AV, SV, CV, because those
6254 objects will become corrupted by the pointer copy process.
6256 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6262 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6265 sv_setsv(rv, &PL_sv_undef);
6269 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6274 =for apidoc sv_setref_iv
6276 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6277 argument will be upgraded to an RV. That RV will be modified to point to
6278 the new SV. The C<classname> argument indicates the package for the
6279 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6280 will be returned and will have a reference count of 1.
6286 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6288 sv_setiv(newSVrv(rv,classname), iv);
6293 =for apidoc sv_setref_nv
6295 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6296 argument will be upgraded to an RV. That RV will be modified to point to
6297 the new SV. The C<classname> argument indicates the package for the
6298 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6299 will be returned and will have a reference count of 1.
6305 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6307 sv_setnv(newSVrv(rv,classname), nv);
6312 =for apidoc sv_setref_pvn
6314 Copies a string into a new SV, optionally blessing the SV. The length of the
6315 string must be specified with C<n>. The C<rv> argument will be upgraded to
6316 an RV. That RV will be modified to point to the new SV. The C<classname>
6317 argument indicates the package for the blessing. Set C<classname> to
6318 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6319 a reference count of 1.
6321 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6327 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6329 sv_setpvn(newSVrv(rv,classname), pv, n);
6334 =for apidoc sv_bless
6336 Blesses an SV into a specified package. The SV must be an RV. The package
6337 must be designated by its stash (see C<gv_stashpv()>). The reference count
6338 of the SV is unaffected.
6344 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6348 Perl_croak(aTHX_ "Can't bless non-reference value");
6350 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6351 if (SvREADONLY(tmpRef))
6352 Perl_croak(aTHX_ PL_no_modify);
6353 if (SvOBJECT(tmpRef)) {
6354 if (SvTYPE(tmpRef) != SVt_PVIO)
6356 SvREFCNT_dec(SvSTASH(tmpRef));
6359 SvOBJECT_on(tmpRef);
6360 if (SvTYPE(tmpRef) != SVt_PVIO)
6362 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6363 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6374 S_sv_unglob(pTHX_ SV *sv)
6378 assert(SvTYPE(sv) == SVt_PVGV);
6383 SvREFCNT_dec(GvSTASH(sv));
6384 GvSTASH(sv) = Nullhv;
6386 sv_unmagic(sv, '*');
6387 Safefree(GvNAME(sv));
6390 /* need to keep SvANY(sv) in the right arena */
6391 xpvmg = new_XPVMG();
6392 StructCopy(SvANY(sv), xpvmg, XPVMG);
6393 del_XPVGV(SvANY(sv));
6396 SvFLAGS(sv) &= ~SVTYPEMASK;
6397 SvFLAGS(sv) |= SVt_PVMG;
6401 =for apidoc sv_unref_flags
6403 Unsets the RV status of the SV, and decrements the reference count of
6404 whatever was being referenced by the RV. This can almost be thought of
6405 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6406 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6407 (otherwise the decrementing is conditional on the reference count being
6408 different from one or the reference being a readonly SV).
6415 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6419 if (SvWEAKREF(sv)) {
6427 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6429 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6430 sv_2mortal(rv); /* Schedule for freeing later */
6434 =for apidoc sv_unref
6436 Unsets the RV status of the SV, and decrements the reference count of
6437 whatever was being referenced by the RV. This can almost be thought of
6438 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6439 being zero. See C<SvROK_off>.
6445 Perl_sv_unref(pTHX_ SV *sv)
6447 sv_unref_flags(sv, 0);
6451 Perl_sv_taint(pTHX_ SV *sv)
6453 sv_magic((sv), Nullsv, 't', Nullch, 0);
6457 Perl_sv_untaint(pTHX_ SV *sv)
6459 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6460 MAGIC *mg = mg_find(sv, 't');
6467 Perl_sv_tainted(pTHX_ SV *sv)
6469 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6470 MAGIC *mg = mg_find(sv, 't');
6471 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6478 =for apidoc sv_setpviv
6480 Copies an integer into the given SV, also updating its string value.
6481 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6487 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6489 char buf[TYPE_CHARS(UV)];
6491 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6493 sv_setpvn(sv, ptr, ebuf - ptr);
6498 =for apidoc sv_setpviv_mg
6500 Like C<sv_setpviv>, but also handles 'set' magic.
6506 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6508 char buf[TYPE_CHARS(UV)];
6510 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6512 sv_setpvn(sv, ptr, ebuf - ptr);
6516 #if defined(PERL_IMPLICIT_CONTEXT)
6518 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6522 va_start(args, pat);
6523 sv_vsetpvf(sv, pat, &args);
6529 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6533 va_start(args, pat);
6534 sv_vsetpvf_mg(sv, pat, &args);
6540 =for apidoc sv_setpvf
6542 Processes its arguments like C<sprintf> and sets an SV to the formatted
6543 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6549 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6552 va_start(args, pat);
6553 sv_vsetpvf(sv, pat, &args);
6558 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6560 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6564 =for apidoc sv_setpvf_mg
6566 Like C<sv_setpvf>, but also handles 'set' magic.
6572 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6575 va_start(args, pat);
6576 sv_vsetpvf_mg(sv, pat, &args);
6581 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6583 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6587 #if defined(PERL_IMPLICIT_CONTEXT)
6589 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6593 va_start(args, pat);
6594 sv_vcatpvf(sv, pat, &args);
6599 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6603 va_start(args, pat);
6604 sv_vcatpvf_mg(sv, pat, &args);
6610 =for apidoc sv_catpvf
6612 Processes its arguments like C<sprintf> and appends the formatted output
6613 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6614 typically be called after calling this function to handle 'set' magic.
6620 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6623 va_start(args, pat);
6624 sv_vcatpvf(sv, pat, &args);
6629 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6631 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6635 =for apidoc sv_catpvf_mg
6637 Like C<sv_catpvf>, but also handles 'set' magic.
6643 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6646 va_start(args, pat);
6647 sv_vcatpvf_mg(sv, pat, &args);
6652 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6654 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6659 =for apidoc sv_vsetpvfn
6661 Works like C<vcatpvfn> but copies the text into the SV instead of
6668 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6670 sv_setpvn(sv, "", 0);
6671 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6675 =for apidoc sv_vcatpvfn
6677 Processes its arguments like C<vsprintf> and appends the formatted output
6678 to an SV. Uses an array of SVs if the C style variable argument list is
6679 missing (NULL). When running with taint checks enabled, indicates via
6680 C<maybe_tainted> if results are untrustworthy (often due to the use of
6687 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6694 static char nullstr[] = "(null)";
6697 /* no matter what, this is a string now */
6698 (void)SvPV_force(sv, origlen);
6700 /* special-case "", "%s", and "%_" */
6703 if (patlen == 2 && pat[0] == '%') {
6707 char *s = va_arg(*args, char*);
6708 sv_catpv(sv, s ? s : nullstr);
6710 else if (svix < svmax) {
6711 sv_catsv(sv, *svargs);
6712 if (DO_UTF8(*svargs))
6718 argsv = va_arg(*args, SV*);
6719 sv_catsv(sv, argsv);
6724 /* See comment on '_' below */
6729 patend = (char*)pat + patlen;
6730 for (p = (char*)pat; p < patend; p = q) {
6733 bool vectorize = FALSE;
6740 bool has_precis = FALSE;
6742 bool is_utf = FALSE;
6745 U8 utf8buf[UTF8_MAXLEN+1];
6746 STRLEN esignlen = 0;
6748 char *eptr = Nullch;
6750 /* Times 4: a decimal digit takes more than 3 binary digits.
6751 * NV_DIG: mantissa takes than many decimal digits.
6752 * Plus 32: Playing safe. */
6753 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6754 /* large enough for "%#.#f" --chip */
6755 /* what about long double NVs? --jhi */
6758 U8 *vecstr = Null(U8*);
6770 STRLEN dotstrlen = 1;
6771 I32 epix = 0; /* explicit parameter index */
6772 I32 ewix = 0; /* explicit width index */
6773 bool asterisk = FALSE;
6775 for (q = p; q < patend && *q != '%'; ++q) ;
6777 sv_catpvn(sv, p, q - p);
6806 case '*': /* printf("%*vX",":",$ipv6addr) */
6811 vecsv = va_arg(*args, SV*);
6812 else if (svix < svmax)
6813 vecsv = svargs[svix++];
6816 dotstr = SvPVx(vecsv,dotstrlen);
6844 case '1': case '2': case '3':
6845 case '4': case '5': case '6':
6846 case '7': case '8': case '9':
6849 width = width * 10 + (*q++ - '0');
6851 if (asterisk && ewix == 0) {
6856 } else if (epix == 0) {
6868 i = va_arg(*args, int);
6870 i = (ewix ? ewix <= svmax : svix < svmax) ?
6871 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6873 width = (i < 0) ? -i : i;
6882 i = va_arg(*args, int);
6884 i = (ewix ? ewix <= svmax : svix < svmax)
6885 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6886 precis = (i < 0) ? 0 : i;
6892 precis = precis * 10 + (*q++ - '0');
6899 vecsv = va_arg(*args, SV*);
6900 vecstr = (U8*)SvPVx(vecsv,veclen);
6901 utf = DO_UTF8(vecsv);
6903 else if (epix ? epix <= svmax : svix < svmax) {
6904 vecsv = svargs[epix ? epix-1 : svix++];
6905 vecstr = (U8*)SvPVx(vecsv,veclen);
6906 utf = DO_UTF8(vecsv);
6917 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6928 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6929 if (*(q + 1) == 'l') { /* lld, llf */
6956 uv = va_arg(*args, int);
6958 uv = (epix ? epix <= svmax : svix < svmax) ?
6959 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6960 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6961 eptr = (char*)utf8buf;
6962 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6974 eptr = va_arg(*args, char*);
6976 #ifdef MACOS_TRADITIONAL
6977 /* On MacOS, %#s format is used for Pascal strings */
6982 elen = strlen(eptr);
6985 elen = sizeof nullstr - 1;
6988 else if (epix ? epix <= svmax : svix < svmax) {
6989 argsv = svargs[epix ? epix-1 : svix++];
6990 eptr = SvPVx(argsv, elen);
6991 if (DO_UTF8(argsv)) {
6992 if (has_precis && precis < elen) {
6994 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6997 if (width) { /* fudge width (can't fudge elen) */
6998 width += elen - sv_len_utf8(argsv);
7007 * The "%_" hack might have to be changed someday,
7008 * if ISO or ANSI decide to use '_' for something.
7009 * So we keep it hidden from users' code.
7013 argsv = va_arg(*args,SV*);
7014 eptr = SvPVx(argsv, elen);
7020 if (has_precis && elen > precis)
7030 uv = PTR2UV(va_arg(*args, void*));
7032 uv = (epix ? epix <= svmax : svix < svmax) ?
7033 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
7053 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7063 case 'h': iv = (short)va_arg(*args, int); break;
7064 default: iv = va_arg(*args, int); break;
7065 case 'l': iv = va_arg(*args, long); break;
7066 case 'V': iv = va_arg(*args, IV); break;
7068 case 'q': iv = va_arg(*args, Quad_t); break;
7073 iv = (epix ? epix <= svmax : svix < svmax) ?
7074 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
7076 case 'h': iv = (short)iv; break;
7078 case 'l': iv = (long)iv; break;
7081 case 'q': iv = (Quad_t)iv; break;
7088 esignbuf[esignlen++] = plus;
7092 esignbuf[esignlen++] = '-';
7136 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7146 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7147 default: uv = va_arg(*args, unsigned); break;
7148 case 'l': uv = va_arg(*args, unsigned long); break;
7149 case 'V': uv = va_arg(*args, UV); break;
7151 case 'q': uv = va_arg(*args, Quad_t); break;
7156 uv = (epix ? epix <= svmax : svix < svmax) ?
7157 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
7159 case 'h': uv = (unsigned short)uv; break;
7161 case 'l': uv = (unsigned long)uv; break;
7164 case 'q': uv = (Quad_t)uv; break;
7170 eptr = ebuf + sizeof ebuf;
7176 p = (char*)((c == 'X')
7177 ? "0123456789ABCDEF" : "0123456789abcdef");
7183 esignbuf[esignlen++] = '0';
7184 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7190 *--eptr = '0' + dig;
7192 if (alt && *eptr != '0')
7198 *--eptr = '0' + dig;
7201 esignbuf[esignlen++] = '0';
7202 esignbuf[esignlen++] = 'b';
7205 default: /* it had better be ten or less */
7206 #if defined(PERL_Y2KWARN)
7207 if (ckWARN(WARN_Y2K)) {
7209 char *s = SvPV(sv,n);
7210 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7211 && (n == 2 || !isDIGIT(s[n-3])))
7213 Perl_warner(aTHX_ WARN_Y2K,
7214 "Possible Y2K bug: %%%c %s",
7215 c, "format string following '19'");
7221 *--eptr = '0' + dig;
7222 } while (uv /= base);
7225 elen = (ebuf + sizeof ebuf) - eptr;
7228 zeros = precis - elen;
7229 else if (precis == 0 && elen == 1 && *eptr == '0')
7234 /* FLOATING POINT */
7237 c = 'f'; /* maybe %F isn't supported here */
7243 /* This is evil, but floating point is even more evil */
7247 nv = va_arg(*args, NV);
7249 nv = (epix ? epix <= svmax : svix < svmax) ?
7250 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
7253 if (c != 'e' && c != 'E') {
7255 (void)Perl_frexp(nv, &i);
7256 if (i == PERL_INT_MIN)
7257 Perl_die(aTHX_ "panic: frexp");
7259 need = BIT_DIGITS(i);
7261 need += has_precis ? precis : 6; /* known default */
7265 need += 20; /* fudge factor */
7266 if (PL_efloatsize < need) {
7267 Safefree(PL_efloatbuf);
7268 PL_efloatsize = need + 20; /* more fudge */
7269 New(906, PL_efloatbuf, PL_efloatsize, char);
7270 PL_efloatbuf[0] = '\0';
7273 eptr = ebuf + sizeof ebuf;
7276 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7278 /* Copy the one or more characters in a long double
7279 * format before the 'base' ([efgEFG]) character to
7280 * the format string. */
7281 static char const prifldbl[] = PERL_PRIfldbl;
7282 char const *p = prifldbl + sizeof(prifldbl) - 3;
7283 while (p >= prifldbl) { *--eptr = *p--; }
7288 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7293 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7305 /* No taint. Otherwise we are in the strange situation
7306 * where printf() taints but print($float) doesn't.
7308 (void)sprintf(PL_efloatbuf, eptr, nv);
7310 eptr = PL_efloatbuf;
7311 elen = strlen(PL_efloatbuf);
7318 i = SvCUR(sv) - origlen;
7321 case 'h': *(va_arg(*args, short*)) = i; break;
7322 default: *(va_arg(*args, int*)) = i; break;
7323 case 'l': *(va_arg(*args, long*)) = i; break;
7324 case 'V': *(va_arg(*args, IV*)) = i; break;
7326 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7330 else if (epix ? epix <= svmax : svix < svmax)
7331 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
7332 continue; /* not "break" */
7339 if (!args && ckWARN(WARN_PRINTF) &&
7340 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7341 SV *msg = sv_newmortal();
7342 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7343 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7346 Perl_sv_catpvf(aTHX_ msg,
7347 "\"%%%c\"", c & 0xFF);
7349 Perl_sv_catpvf(aTHX_ msg,
7350 "\"%%\\%03"UVof"\"",
7353 sv_catpv(msg, "end of string");
7354 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7357 /* output mangled stuff ... */
7363 /* ... right here, because formatting flags should not apply */
7364 SvGROW(sv, SvCUR(sv) + elen + 1);
7366 memcpy(p, eptr, elen);
7369 SvCUR(sv) = p - SvPVX(sv);
7370 continue; /* not "break" */
7373 have = esignlen + zeros + elen;
7374 need = (have > width ? have : width);
7377 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7379 if (esignlen && fill == '0') {
7380 for (i = 0; i < esignlen; i++)
7384 memset(p, fill, gap);
7387 if (esignlen && fill != '0') {
7388 for (i = 0; i < esignlen; i++)
7392 for (i = zeros; i; i--)
7396 memcpy(p, eptr, elen);
7400 memset(p, ' ', gap);
7405 memcpy(p, dotstr, dotstrlen);
7409 vectorize = FALSE; /* done iterating over vecstr */
7414 SvCUR(sv) = p - SvPVX(sv);
7422 #if defined(USE_ITHREADS)
7424 #if defined(USE_THREADS)
7425 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7428 #ifndef GpREFCNT_inc
7429 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7433 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7434 #define av_dup(s) (AV*)sv_dup((SV*)s)
7435 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7436 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7437 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7438 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7439 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7440 #define io_dup(s) (IO*)sv_dup((SV*)s)
7441 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7442 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7443 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7444 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7445 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7448 Perl_re_dup(pTHX_ REGEXP *r)
7450 /* XXX fix when pmop->op_pmregexp becomes shared */
7451 return ReREFCNT_inc(r);
7455 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7459 return (PerlIO*)NULL;
7461 /* look for it in the table first */
7462 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7466 /* create anew and remember what it is */
7467 ret = PerlIO_fdupopen(aTHX_ fp);
7468 ptr_table_store(PL_ptr_table, fp, ret);
7473 Perl_dirp_dup(pTHX_ DIR *dp)
7482 Perl_gp_dup(pTHX_ GP *gp)
7487 /* look for it in the table first */
7488 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7492 /* create anew and remember what it is */
7493 Newz(0, ret, 1, GP);
7494 ptr_table_store(PL_ptr_table, gp, ret);
7497 ret->gp_refcnt = 0; /* must be before any other dups! */
7498 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7499 ret->gp_io = io_dup_inc(gp->gp_io);
7500 ret->gp_form = cv_dup_inc(gp->gp_form);
7501 ret->gp_av = av_dup_inc(gp->gp_av);
7502 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7503 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7504 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7505 ret->gp_cvgen = gp->gp_cvgen;
7506 ret->gp_flags = gp->gp_flags;
7507 ret->gp_line = gp->gp_line;
7508 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7513 Perl_mg_dup(pTHX_ MAGIC *mg)
7515 MAGIC *mgret = (MAGIC*)NULL;
7518 return (MAGIC*)NULL;
7519 /* look for it in the table first */
7520 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7524 for (; mg; mg = mg->mg_moremagic) {
7526 Newz(0, nmg, 1, MAGIC);
7530 mgprev->mg_moremagic = nmg;
7531 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7532 nmg->mg_private = mg->mg_private;
7533 nmg->mg_type = mg->mg_type;
7534 nmg->mg_flags = mg->mg_flags;
7535 if (mg->mg_type == 'r') {
7536 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7539 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7540 ? sv_dup_inc(mg->mg_obj)
7541 : sv_dup(mg->mg_obj);
7543 nmg->mg_len = mg->mg_len;
7544 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7545 if (mg->mg_ptr && mg->mg_type != 'g') {
7546 if (mg->mg_len >= 0) {
7547 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7548 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7549 AMT *amtp = (AMT*)mg->mg_ptr;
7550 AMT *namtp = (AMT*)nmg->mg_ptr;
7552 for (i = 1; i < NofAMmeth; i++) {
7553 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7557 else if (mg->mg_len == HEf_SVKEY)
7558 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7566 Perl_ptr_table_new(pTHX)
7569 Newz(0, tbl, 1, PTR_TBL_t);
7572 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7577 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7579 PTR_TBL_ENT_t *tblent;
7580 UV hash = PTR2UV(sv);
7582 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7583 for (; tblent; tblent = tblent->next) {
7584 if (tblent->oldval == sv)
7585 return tblent->newval;
7591 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7593 PTR_TBL_ENT_t *tblent, **otblent;
7594 /* XXX this may be pessimal on platforms where pointers aren't good
7595 * hash values e.g. if they grow faster in the most significant
7597 UV hash = PTR2UV(oldv);
7601 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7602 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7603 if (tblent->oldval == oldv) {
7604 tblent->newval = newv;
7609 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7610 tblent->oldval = oldv;
7611 tblent->newval = newv;
7612 tblent->next = *otblent;
7615 if (i && tbl->tbl_items > tbl->tbl_max)
7616 ptr_table_split(tbl);
7620 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7622 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7623 UV oldsize = tbl->tbl_max + 1;
7624 UV newsize = oldsize * 2;
7627 Renew(ary, newsize, PTR_TBL_ENT_t*);
7628 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7629 tbl->tbl_max = --newsize;
7631 for (i=0; i < oldsize; i++, ary++) {
7632 PTR_TBL_ENT_t **curentp, **entp, *ent;
7635 curentp = ary + oldsize;
7636 for (entp = ary, ent = *ary; ent; ent = *entp) {
7637 if ((newsize & PTR2UV(ent->oldval)) != i) {
7639 ent->next = *curentp;
7654 Perl_sv_dup(pTHX_ SV *sstr)
7658 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7660 /* look for it in the table first */
7661 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7665 /* create anew and remember what it is */
7667 ptr_table_store(PL_ptr_table, sstr, dstr);
7670 SvFLAGS(dstr) = SvFLAGS(sstr);
7671 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7672 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7675 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7676 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7677 PL_watch_pvx, SvPVX(sstr));
7680 switch (SvTYPE(sstr)) {
7685 SvANY(dstr) = new_XIV();
7686 SvIVX(dstr) = SvIVX(sstr);
7689 SvANY(dstr) = new_XNV();
7690 SvNVX(dstr) = SvNVX(sstr);
7693 SvANY(dstr) = new_XRV();
7694 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7697 SvANY(dstr) = new_XPV();
7698 SvCUR(dstr) = SvCUR(sstr);
7699 SvLEN(dstr) = SvLEN(sstr);
7701 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7702 else if (SvPVX(sstr) && SvLEN(sstr))
7703 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7705 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7708 SvANY(dstr) = new_XPVIV();
7709 SvCUR(dstr) = SvCUR(sstr);
7710 SvLEN(dstr) = SvLEN(sstr);
7711 SvIVX(dstr) = SvIVX(sstr);
7713 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7714 else if (SvPVX(sstr) && SvLEN(sstr))
7715 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7717 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7720 SvANY(dstr) = new_XPVNV();
7721 SvCUR(dstr) = SvCUR(sstr);
7722 SvLEN(dstr) = SvLEN(sstr);
7723 SvIVX(dstr) = SvIVX(sstr);
7724 SvNVX(dstr) = SvNVX(sstr);
7726 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7727 else if (SvPVX(sstr) && SvLEN(sstr))
7728 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7730 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7733 SvANY(dstr) = new_XPVMG();
7734 SvCUR(dstr) = SvCUR(sstr);
7735 SvLEN(dstr) = SvLEN(sstr);
7736 SvIVX(dstr) = SvIVX(sstr);
7737 SvNVX(dstr) = SvNVX(sstr);
7738 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7739 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7741 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7742 else if (SvPVX(sstr) && SvLEN(sstr))
7743 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7745 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7748 SvANY(dstr) = new_XPVBM();
7749 SvCUR(dstr) = SvCUR(sstr);
7750 SvLEN(dstr) = SvLEN(sstr);
7751 SvIVX(dstr) = SvIVX(sstr);
7752 SvNVX(dstr) = SvNVX(sstr);
7753 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7754 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7756 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7757 else if (SvPVX(sstr) && SvLEN(sstr))
7758 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7760 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7761 BmRARE(dstr) = BmRARE(sstr);
7762 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7763 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7766 SvANY(dstr) = new_XPVLV();
7767 SvCUR(dstr) = SvCUR(sstr);
7768 SvLEN(dstr) = SvLEN(sstr);
7769 SvIVX(dstr) = SvIVX(sstr);
7770 SvNVX(dstr) = SvNVX(sstr);
7771 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7772 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7774 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7775 else if (SvPVX(sstr) && SvLEN(sstr))
7776 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7778 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7779 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7780 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7781 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7782 LvTYPE(dstr) = LvTYPE(sstr);
7785 SvANY(dstr) = new_XPVGV();
7786 SvCUR(dstr) = SvCUR(sstr);
7787 SvLEN(dstr) = SvLEN(sstr);
7788 SvIVX(dstr) = SvIVX(sstr);
7789 SvNVX(dstr) = SvNVX(sstr);
7790 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7791 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7793 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7794 else if (SvPVX(sstr) && SvLEN(sstr))
7795 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7797 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7798 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7799 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7800 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7801 GvFLAGS(dstr) = GvFLAGS(sstr);
7802 GvGP(dstr) = gp_dup(GvGP(sstr));
7803 (void)GpREFCNT_inc(GvGP(dstr));
7806 SvANY(dstr) = new_XPVIO();
7807 SvCUR(dstr) = SvCUR(sstr);
7808 SvLEN(dstr) = SvLEN(sstr);
7809 SvIVX(dstr) = SvIVX(sstr);
7810 SvNVX(dstr) = SvNVX(sstr);
7811 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7812 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7814 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7815 else if (SvPVX(sstr) && SvLEN(sstr))
7816 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7818 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7819 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7820 if (IoOFP(sstr) == IoIFP(sstr))
7821 IoOFP(dstr) = IoIFP(dstr);
7823 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7824 /* PL_rsfp_filters entries have fake IoDIRP() */
7825 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7826 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7828 IoDIRP(dstr) = IoDIRP(sstr);
7829 IoLINES(dstr) = IoLINES(sstr);
7830 IoPAGE(dstr) = IoPAGE(sstr);
7831 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7832 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7833 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7834 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7835 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7836 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7837 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7838 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7839 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7840 IoTYPE(dstr) = IoTYPE(sstr);
7841 IoFLAGS(dstr) = IoFLAGS(sstr);
7844 SvANY(dstr) = new_XPVAV();
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 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7852 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7853 if (AvARRAY((AV*)sstr)) {
7854 SV **dst_ary, **src_ary;
7855 SSize_t items = AvFILLp((AV*)sstr) + 1;
7857 src_ary = AvARRAY((AV*)sstr);
7858 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7859 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7860 SvPVX(dstr) = (char*)dst_ary;
7861 AvALLOC((AV*)dstr) = dst_ary;
7862 if (AvREAL((AV*)sstr)) {
7864 *dst_ary++ = sv_dup_inc(*src_ary++);
7868 *dst_ary++ = sv_dup(*src_ary++);
7870 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7871 while (items-- > 0) {
7872 *dst_ary++ = &PL_sv_undef;
7876 SvPVX(dstr) = Nullch;
7877 AvALLOC((AV*)dstr) = (SV**)NULL;
7881 SvANY(dstr) = new_XPVHV();
7882 SvCUR(dstr) = SvCUR(sstr);
7883 SvLEN(dstr) = SvLEN(sstr);
7884 SvIVX(dstr) = SvIVX(sstr);
7885 SvNVX(dstr) = SvNVX(sstr);
7886 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7887 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7888 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7889 if (HvARRAY((HV*)sstr)) {
7891 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7892 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7893 Newz(0, dxhv->xhv_array,
7894 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7895 while (i <= sxhv->xhv_max) {
7896 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7897 !!HvSHAREKEYS(sstr));
7900 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7903 SvPVX(dstr) = Nullch;
7904 HvEITER((HV*)dstr) = (HE*)NULL;
7906 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7907 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7910 SvANY(dstr) = new_XPVFM();
7911 FmLINES(dstr) = FmLINES(sstr);
7915 SvANY(dstr) = new_XPVCV();
7917 SvCUR(dstr) = SvCUR(sstr);
7918 SvLEN(dstr) = SvLEN(sstr);
7919 SvIVX(dstr) = SvIVX(sstr);
7920 SvNVX(dstr) = SvNVX(sstr);
7921 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7922 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7923 if (SvPVX(sstr) && SvLEN(sstr))
7924 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7926 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7927 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7928 CvSTART(dstr) = CvSTART(sstr);
7929 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7930 CvXSUB(dstr) = CvXSUB(sstr);
7931 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7932 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7933 CvDEPTH(dstr) = CvDEPTH(sstr);
7934 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7935 /* XXX padlists are real, but pretend to be not */
7936 AvREAL_on(CvPADLIST(sstr));
7937 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7938 AvREAL_off(CvPADLIST(sstr));
7939 AvREAL_off(CvPADLIST(dstr));
7942 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7943 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7944 CvFLAGS(dstr) = CvFLAGS(sstr);
7947 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7951 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7958 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7963 return (PERL_CONTEXT*)NULL;
7965 /* look for it in the table first */
7966 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7970 /* create anew and remember what it is */
7971 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7972 ptr_table_store(PL_ptr_table, cxs, ncxs);
7975 PERL_CONTEXT *cx = &cxs[ix];
7976 PERL_CONTEXT *ncx = &ncxs[ix];
7977 ncx->cx_type = cx->cx_type;
7978 if (CxTYPE(cx) == CXt_SUBST) {
7979 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7982 ncx->blk_oldsp = cx->blk_oldsp;
7983 ncx->blk_oldcop = cx->blk_oldcop;
7984 ncx->blk_oldretsp = cx->blk_oldretsp;
7985 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7986 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7987 ncx->blk_oldpm = cx->blk_oldpm;
7988 ncx->blk_gimme = cx->blk_gimme;
7989 switch (CxTYPE(cx)) {
7991 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7992 ? cv_dup_inc(cx->blk_sub.cv)
7993 : cv_dup(cx->blk_sub.cv));
7994 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7995 ? av_dup_inc(cx->blk_sub.argarray)
7997 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7998 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7999 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8000 ncx->blk_sub.lval = cx->blk_sub.lval;
8003 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8004 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8005 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8006 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8007 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8010 ncx->blk_loop.label = cx->blk_loop.label;
8011 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8012 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8013 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8014 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8015 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8016 ? cx->blk_loop.iterdata
8017 : gv_dup((GV*)cx->blk_loop.iterdata));
8018 ncx->blk_loop.oldcurpad
8019 = (SV**)ptr_table_fetch(PL_ptr_table,
8020 cx->blk_loop.oldcurpad);
8021 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8022 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8023 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8024 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8025 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8028 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8029 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8030 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8031 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8044 Perl_si_dup(pTHX_ PERL_SI *si)
8049 return (PERL_SI*)NULL;
8051 /* look for it in the table first */
8052 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8056 /* create anew and remember what it is */
8057 Newz(56, nsi, 1, PERL_SI);
8058 ptr_table_store(PL_ptr_table, si, nsi);
8060 nsi->si_stack = av_dup_inc(si->si_stack);
8061 nsi->si_cxix = si->si_cxix;
8062 nsi->si_cxmax = si->si_cxmax;
8063 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8064 nsi->si_type = si->si_type;
8065 nsi->si_prev = si_dup(si->si_prev);
8066 nsi->si_next = si_dup(si->si_next);
8067 nsi->si_markoff = si->si_markoff;
8072 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8073 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8074 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8075 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8076 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8077 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8078 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8079 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8080 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8081 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8082 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8083 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8086 #define pv_dup_inc(p) SAVEPV(p)
8087 #define pv_dup(p) SAVEPV(p)
8088 #define svp_dup_inc(p,pp) any_dup(p,pp)
8091 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8098 /* look for it in the table first */
8099 ret = ptr_table_fetch(PL_ptr_table, v);
8103 /* see if it is part of the interpreter structure */
8104 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8105 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8113 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8115 ANY *ss = proto_perl->Tsavestack;
8116 I32 ix = proto_perl->Tsavestack_ix;
8117 I32 max = proto_perl->Tsavestack_max;
8130 void (*dptr) (void*);
8131 void (*dxptr) (pTHXo_ void*);
8134 Newz(54, nss, max, ANY);
8140 case SAVEt_ITEM: /* normal string */
8141 sv = (SV*)POPPTR(ss,ix);
8142 TOPPTR(nss,ix) = sv_dup_inc(sv);
8143 sv = (SV*)POPPTR(ss,ix);
8144 TOPPTR(nss,ix) = sv_dup_inc(sv);
8146 case SAVEt_SV: /* scalar reference */
8147 sv = (SV*)POPPTR(ss,ix);
8148 TOPPTR(nss,ix) = sv_dup_inc(sv);
8149 gv = (GV*)POPPTR(ss,ix);
8150 TOPPTR(nss,ix) = gv_dup_inc(gv);
8152 case SAVEt_GENERIC_PVREF: /* generic char* */
8153 c = (char*)POPPTR(ss,ix);
8154 TOPPTR(nss,ix) = pv_dup(c);
8155 ptr = POPPTR(ss,ix);
8156 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8158 case SAVEt_GENERIC_SVREF: /* generic sv */
8159 case SAVEt_SVREF: /* scalar reference */
8160 sv = (SV*)POPPTR(ss,ix);
8161 TOPPTR(nss,ix) = sv_dup_inc(sv);
8162 ptr = POPPTR(ss,ix);
8163 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8165 case SAVEt_AV: /* array reference */
8166 av = (AV*)POPPTR(ss,ix);
8167 TOPPTR(nss,ix) = av_dup_inc(av);
8168 gv = (GV*)POPPTR(ss,ix);
8169 TOPPTR(nss,ix) = gv_dup(gv);
8171 case SAVEt_HV: /* hash reference */
8172 hv = (HV*)POPPTR(ss,ix);
8173 TOPPTR(nss,ix) = hv_dup_inc(hv);
8174 gv = (GV*)POPPTR(ss,ix);
8175 TOPPTR(nss,ix) = gv_dup(gv);
8177 case SAVEt_INT: /* int reference */
8178 ptr = POPPTR(ss,ix);
8179 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8180 intval = (int)POPINT(ss,ix);
8181 TOPINT(nss,ix) = intval;
8183 case SAVEt_LONG: /* long reference */
8184 ptr = POPPTR(ss,ix);
8185 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8186 longval = (long)POPLONG(ss,ix);
8187 TOPLONG(nss,ix) = longval;
8189 case SAVEt_I32: /* I32 reference */
8190 case SAVEt_I16: /* I16 reference */
8191 case SAVEt_I8: /* I8 reference */
8192 ptr = POPPTR(ss,ix);
8193 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8197 case SAVEt_IV: /* IV reference */
8198 ptr = POPPTR(ss,ix);
8199 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8203 case SAVEt_SPTR: /* SV* reference */
8204 ptr = POPPTR(ss,ix);
8205 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8206 sv = (SV*)POPPTR(ss,ix);
8207 TOPPTR(nss,ix) = sv_dup(sv);
8209 case SAVEt_VPTR: /* random* reference */
8210 ptr = POPPTR(ss,ix);
8211 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8212 ptr = POPPTR(ss,ix);
8213 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8215 case SAVEt_PPTR: /* char* reference */
8216 ptr = POPPTR(ss,ix);
8217 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8218 c = (char*)POPPTR(ss,ix);
8219 TOPPTR(nss,ix) = pv_dup(c);
8221 case SAVEt_HPTR: /* HV* reference */
8222 ptr = POPPTR(ss,ix);
8223 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8224 hv = (HV*)POPPTR(ss,ix);
8225 TOPPTR(nss,ix) = hv_dup(hv);
8227 case SAVEt_APTR: /* AV* reference */
8228 ptr = POPPTR(ss,ix);
8229 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8230 av = (AV*)POPPTR(ss,ix);
8231 TOPPTR(nss,ix) = av_dup(av);
8234 gv = (GV*)POPPTR(ss,ix);
8235 TOPPTR(nss,ix) = gv_dup(gv);
8237 case SAVEt_GP: /* scalar reference */
8238 gp = (GP*)POPPTR(ss,ix);
8239 TOPPTR(nss,ix) = gp = gp_dup(gp);
8240 (void)GpREFCNT_inc(gp);
8241 gv = (GV*)POPPTR(ss,ix);
8242 TOPPTR(nss,ix) = gv_dup_inc(c);
8243 c = (char*)POPPTR(ss,ix);
8244 TOPPTR(nss,ix) = pv_dup(c);
8251 sv = (SV*)POPPTR(ss,ix);
8252 TOPPTR(nss,ix) = sv_dup_inc(sv);
8255 ptr = POPPTR(ss,ix);
8256 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8257 /* these are assumed to be refcounted properly */
8258 switch (((OP*)ptr)->op_type) {
8265 TOPPTR(nss,ix) = ptr;
8270 TOPPTR(nss,ix) = Nullop;
8275 TOPPTR(nss,ix) = Nullop;
8278 c = (char*)POPPTR(ss,ix);
8279 TOPPTR(nss,ix) = pv_dup_inc(c);
8282 longval = POPLONG(ss,ix);
8283 TOPLONG(nss,ix) = longval;
8286 hv = (HV*)POPPTR(ss,ix);
8287 TOPPTR(nss,ix) = hv_dup_inc(hv);
8288 c = (char*)POPPTR(ss,ix);
8289 TOPPTR(nss,ix) = pv_dup_inc(c);
8293 case SAVEt_DESTRUCTOR:
8294 ptr = POPPTR(ss,ix);
8295 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8296 dptr = POPDPTR(ss,ix);
8297 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8299 case SAVEt_DESTRUCTOR_X:
8300 ptr = POPPTR(ss,ix);
8301 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8302 dxptr = POPDXPTR(ss,ix);
8303 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8305 case SAVEt_REGCONTEXT:
8311 case SAVEt_STACK_POS: /* Position on Perl stack */
8315 case SAVEt_AELEM: /* array element */
8316 sv = (SV*)POPPTR(ss,ix);
8317 TOPPTR(nss,ix) = sv_dup_inc(sv);
8320 av = (AV*)POPPTR(ss,ix);
8321 TOPPTR(nss,ix) = av_dup_inc(av);
8323 case SAVEt_HELEM: /* hash element */
8324 sv = (SV*)POPPTR(ss,ix);
8325 TOPPTR(nss,ix) = sv_dup_inc(sv);
8326 sv = (SV*)POPPTR(ss,ix);
8327 TOPPTR(nss,ix) = sv_dup_inc(sv);
8328 hv = (HV*)POPPTR(ss,ix);
8329 TOPPTR(nss,ix) = hv_dup_inc(hv);
8332 ptr = POPPTR(ss,ix);
8333 TOPPTR(nss,ix) = ptr;
8340 av = (AV*)POPPTR(ss,ix);
8341 TOPPTR(nss,ix) = av_dup(av);
8344 longval = (long)POPLONG(ss,ix);
8345 TOPLONG(nss,ix) = longval;
8346 ptr = POPPTR(ss,ix);
8347 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8348 sv = (SV*)POPPTR(ss,ix);
8349 TOPPTR(nss,ix) = sv_dup(sv);
8352 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8364 perl_clone(PerlInterpreter *proto_perl, UV flags)
8367 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8370 #ifdef PERL_IMPLICIT_SYS
8371 return perl_clone_using(proto_perl, flags,
8373 proto_perl->IMemShared,
8374 proto_perl->IMemParse,
8384 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8385 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8386 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8387 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8388 struct IPerlDir* ipD, struct IPerlSock* ipS,
8389 struct IPerlProc* ipP)
8391 /* XXX many of the string copies here can be optimized if they're
8392 * constants; they need to be allocated as common memory and just
8393 * their pointers copied. */
8397 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8399 PERL_SET_THX(pPerl);
8400 # else /* !PERL_OBJECT */
8401 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8402 PERL_SET_THX(my_perl);
8405 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8410 # else /* !DEBUGGING */
8411 Zero(my_perl, 1, PerlInterpreter);
8412 # endif /* DEBUGGING */
8416 PL_MemShared = ipMS;
8424 # endif /* PERL_OBJECT */
8425 #else /* !PERL_IMPLICIT_SYS */
8427 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8428 PERL_SET_THX(my_perl);
8431 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8436 # else /* !DEBUGGING */
8437 Zero(my_perl, 1, PerlInterpreter);
8438 # endif /* DEBUGGING */
8439 #endif /* PERL_IMPLICIT_SYS */
8442 PL_xiv_arenaroot = NULL;
8444 PL_xnv_arenaroot = NULL;
8446 PL_xrv_arenaroot = NULL;
8448 PL_xpv_arenaroot = NULL;
8450 PL_xpviv_arenaroot = NULL;
8451 PL_xpviv_root = NULL;
8452 PL_xpvnv_arenaroot = NULL;
8453 PL_xpvnv_root = NULL;
8454 PL_xpvcv_arenaroot = NULL;
8455 PL_xpvcv_root = NULL;
8456 PL_xpvav_arenaroot = NULL;
8457 PL_xpvav_root = NULL;
8458 PL_xpvhv_arenaroot = NULL;
8459 PL_xpvhv_root = NULL;
8460 PL_xpvmg_arenaroot = NULL;
8461 PL_xpvmg_root = NULL;
8462 PL_xpvlv_arenaroot = NULL;
8463 PL_xpvlv_root = NULL;
8464 PL_xpvbm_arenaroot = NULL;
8465 PL_xpvbm_root = NULL;
8466 PL_he_arenaroot = NULL;
8468 PL_nice_chunk = NULL;
8469 PL_nice_chunk_size = 0;
8472 PL_sv_root = Nullsv;
8473 PL_sv_arenaroot = Nullsv;
8475 PL_debug = proto_perl->Idebug;
8477 /* create SV map for pointer relocation */
8478 PL_ptr_table = ptr_table_new();
8480 /* initialize these special pointers as early as possible */
8481 SvANY(&PL_sv_undef) = NULL;
8482 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8483 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8484 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8487 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8489 SvANY(&PL_sv_no) = new_XPVNV();
8491 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8492 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8493 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8494 SvCUR(&PL_sv_no) = 0;
8495 SvLEN(&PL_sv_no) = 1;
8496 SvNVX(&PL_sv_no) = 0;
8497 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8500 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8502 SvANY(&PL_sv_yes) = new_XPVNV();
8504 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8505 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8506 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8507 SvCUR(&PL_sv_yes) = 1;
8508 SvLEN(&PL_sv_yes) = 2;
8509 SvNVX(&PL_sv_yes) = 1;
8510 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8512 /* create shared string table */
8513 PL_strtab = newHV();
8514 HvSHAREKEYS_off(PL_strtab);
8515 hv_ksplit(PL_strtab, 512);
8516 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8518 PL_compiling = proto_perl->Icompiling;
8519 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8520 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8521 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8522 if (!specialWARN(PL_compiling.cop_warnings))
8523 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8524 if (!specialCopIO(PL_compiling.cop_io))
8525 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8526 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8528 /* pseudo environmental stuff */
8529 PL_origargc = proto_perl->Iorigargc;
8531 New(0, PL_origargv, i+1, char*);
8532 PL_origargv[i] = '\0';
8534 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8536 PL_envgv = gv_dup(proto_perl->Ienvgv);
8537 PL_incgv = gv_dup(proto_perl->Iincgv);
8538 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8539 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8540 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8541 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8544 PL_minus_c = proto_perl->Iminus_c;
8545 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8546 PL_localpatches = proto_perl->Ilocalpatches;
8547 PL_splitstr = proto_perl->Isplitstr;
8548 PL_preprocess = proto_perl->Ipreprocess;
8549 PL_minus_n = proto_perl->Iminus_n;
8550 PL_minus_p = proto_perl->Iminus_p;
8551 PL_minus_l = proto_perl->Iminus_l;
8552 PL_minus_a = proto_perl->Iminus_a;
8553 PL_minus_F = proto_perl->Iminus_F;
8554 PL_doswitches = proto_perl->Idoswitches;
8555 PL_dowarn = proto_perl->Idowarn;
8556 PL_doextract = proto_perl->Idoextract;
8557 PL_sawampersand = proto_perl->Isawampersand;
8558 PL_unsafe = proto_perl->Iunsafe;
8559 PL_inplace = SAVEPV(proto_perl->Iinplace);
8560 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8561 PL_perldb = proto_perl->Iperldb;
8562 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8564 /* magical thingies */
8565 /* XXX time(&PL_basetime) when asked for? */
8566 PL_basetime = proto_perl->Ibasetime;
8567 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8569 PL_maxsysfd = proto_perl->Imaxsysfd;
8570 PL_multiline = proto_perl->Imultiline;
8571 PL_statusvalue = proto_perl->Istatusvalue;
8573 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8576 /* shortcuts to various I/O objects */
8577 PL_stdingv = gv_dup(proto_perl->Istdingv);
8578 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8579 PL_defgv = gv_dup(proto_perl->Idefgv);
8580 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8581 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8582 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8584 /* shortcuts to regexp stuff */
8585 PL_replgv = gv_dup(proto_perl->Ireplgv);
8587 /* shortcuts to misc objects */
8588 PL_errgv = gv_dup(proto_perl->Ierrgv);
8590 /* shortcuts to debugging objects */
8591 PL_DBgv = gv_dup(proto_perl->IDBgv);
8592 PL_DBline = gv_dup(proto_perl->IDBline);
8593 PL_DBsub = gv_dup(proto_perl->IDBsub);
8594 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8595 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8596 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8597 PL_lineary = av_dup(proto_perl->Ilineary);
8598 PL_dbargs = av_dup(proto_perl->Idbargs);
8601 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8602 PL_curstash = hv_dup(proto_perl->Tcurstash);
8603 PL_debstash = hv_dup(proto_perl->Idebstash);
8604 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8605 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8607 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8608 PL_endav = av_dup_inc(proto_perl->Iendav);
8609 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8610 PL_initav = av_dup_inc(proto_perl->Iinitav);
8612 PL_sub_generation = proto_perl->Isub_generation;
8614 /* funky return mechanisms */
8615 PL_forkprocess = proto_perl->Iforkprocess;
8617 /* subprocess state */
8618 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8620 /* internal state */
8621 PL_tainting = proto_perl->Itainting;
8622 PL_maxo = proto_perl->Imaxo;
8623 if (proto_perl->Iop_mask)
8624 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8626 PL_op_mask = Nullch;
8628 /* current interpreter roots */
8629 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8630 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8631 PL_main_start = proto_perl->Imain_start;
8632 PL_eval_root = proto_perl->Ieval_root;
8633 PL_eval_start = proto_perl->Ieval_start;
8635 /* runtime control stuff */
8636 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8637 PL_copline = proto_perl->Icopline;
8639 PL_filemode = proto_perl->Ifilemode;
8640 PL_lastfd = proto_perl->Ilastfd;
8641 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8644 PL_gensym = proto_perl->Igensym;
8645 PL_preambled = proto_perl->Ipreambled;
8646 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8647 PL_laststatval = proto_perl->Ilaststatval;
8648 PL_laststype = proto_perl->Ilaststype;
8649 PL_mess_sv = Nullsv;
8651 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8652 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8654 /* interpreter atexit processing */
8655 PL_exitlistlen = proto_perl->Iexitlistlen;
8656 if (PL_exitlistlen) {
8657 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8658 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8661 PL_exitlist = (PerlExitListEntry*)NULL;
8662 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8664 PL_profiledata = NULL;
8665 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8666 /* PL_rsfp_filters entries have fake IoDIRP() */
8667 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8669 PL_compcv = cv_dup(proto_perl->Icompcv);
8670 PL_comppad = av_dup(proto_perl->Icomppad);
8671 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8672 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8673 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8674 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8675 proto_perl->Tcurpad);
8677 #ifdef HAVE_INTERP_INTERN
8678 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8681 /* more statics moved here */
8682 PL_generation = proto_perl->Igeneration;
8683 PL_DBcv = cv_dup(proto_perl->IDBcv);
8685 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8686 PL_in_clean_all = proto_perl->Iin_clean_all;
8688 PL_uid = proto_perl->Iuid;
8689 PL_euid = proto_perl->Ieuid;
8690 PL_gid = proto_perl->Igid;
8691 PL_egid = proto_perl->Iegid;
8692 PL_nomemok = proto_perl->Inomemok;
8693 PL_an = proto_perl->Ian;
8694 PL_cop_seqmax = proto_perl->Icop_seqmax;
8695 PL_op_seqmax = proto_perl->Iop_seqmax;
8696 PL_evalseq = proto_perl->Ievalseq;
8697 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8698 PL_origalen = proto_perl->Iorigalen;
8699 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8700 PL_osname = SAVEPV(proto_perl->Iosname);
8701 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8702 PL_sighandlerp = proto_perl->Isighandlerp;
8705 PL_runops = proto_perl->Irunops;
8707 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8710 PL_cshlen = proto_perl->Icshlen;
8711 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8714 PL_lex_state = proto_perl->Ilex_state;
8715 PL_lex_defer = proto_perl->Ilex_defer;
8716 PL_lex_expect = proto_perl->Ilex_expect;
8717 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8718 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8719 PL_lex_starts = proto_perl->Ilex_starts;
8720 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8721 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8722 PL_lex_op = proto_perl->Ilex_op;
8723 PL_lex_inpat = proto_perl->Ilex_inpat;
8724 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8725 PL_lex_brackets = proto_perl->Ilex_brackets;
8726 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8727 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8728 PL_lex_casemods = proto_perl->Ilex_casemods;
8729 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8730 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8732 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8733 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8734 PL_nexttoke = proto_perl->Inexttoke;
8736 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8737 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8738 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8739 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8740 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8741 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8742 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8743 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8744 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8745 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8746 PL_pending_ident = proto_perl->Ipending_ident;
8747 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8749 PL_expect = proto_perl->Iexpect;
8751 PL_multi_start = proto_perl->Imulti_start;
8752 PL_multi_end = proto_perl->Imulti_end;
8753 PL_multi_open = proto_perl->Imulti_open;
8754 PL_multi_close = proto_perl->Imulti_close;
8756 PL_error_count = proto_perl->Ierror_count;
8757 PL_subline = proto_perl->Isubline;
8758 PL_subname = sv_dup_inc(proto_perl->Isubname);
8760 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8761 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8762 PL_padix = proto_perl->Ipadix;
8763 PL_padix_floor = proto_perl->Ipadix_floor;
8764 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8766 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8767 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8768 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8769 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8770 PL_last_lop_op = proto_perl->Ilast_lop_op;
8771 PL_in_my = proto_perl->Iin_my;
8772 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8774 PL_cryptseen = proto_perl->Icryptseen;
8777 PL_hints = proto_perl->Ihints;
8779 PL_amagic_generation = proto_perl->Iamagic_generation;
8781 #ifdef USE_LOCALE_COLLATE
8782 PL_collation_ix = proto_perl->Icollation_ix;
8783 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8784 PL_collation_standard = proto_perl->Icollation_standard;
8785 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8786 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8787 #endif /* USE_LOCALE_COLLATE */
8789 #ifdef USE_LOCALE_NUMERIC
8790 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8791 PL_numeric_standard = proto_perl->Inumeric_standard;
8792 PL_numeric_local = proto_perl->Inumeric_local;
8793 PL_numeric_radix = proto_perl->Inumeric_radix;
8794 #endif /* !USE_LOCALE_NUMERIC */
8796 /* utf8 character classes */
8797 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8798 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8799 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8800 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8801 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8802 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8803 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8804 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8805 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8806 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8807 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8808 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8809 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8810 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8811 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8812 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8813 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8816 PL_last_swash_hv = Nullhv; /* reinits on demand */
8817 PL_last_swash_klen = 0;
8818 PL_last_swash_key[0]= '\0';
8819 PL_last_swash_tmps = (U8*)NULL;
8820 PL_last_swash_slen = 0;
8822 /* perly.c globals */
8823 PL_yydebug = proto_perl->Iyydebug;
8824 PL_yynerrs = proto_perl->Iyynerrs;
8825 PL_yyerrflag = proto_perl->Iyyerrflag;
8826 PL_yychar = proto_perl->Iyychar;
8827 PL_yyval = proto_perl->Iyyval;
8828 PL_yylval = proto_perl->Iyylval;
8830 PL_glob_index = proto_perl->Iglob_index;
8831 PL_srand_called = proto_perl->Isrand_called;
8832 PL_uudmap['M'] = 0; /* reinits on demand */
8833 PL_bitcount = Nullch; /* reinits on demand */
8835 if (proto_perl->Ipsig_ptr) {
8836 int sig_num[] = { SIG_NUM };
8837 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8838 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8839 for (i = 1; PL_sig_name[i]; i++) {
8840 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8841 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8845 PL_psig_ptr = (SV**)NULL;
8846 PL_psig_name = (SV**)NULL;
8849 /* thrdvar.h stuff */
8852 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8853 PL_tmps_ix = proto_perl->Ttmps_ix;
8854 PL_tmps_max = proto_perl->Ttmps_max;
8855 PL_tmps_floor = proto_perl->Ttmps_floor;
8856 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8858 while (i <= PL_tmps_ix) {
8859 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8863 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8864 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8865 Newz(54, PL_markstack, i, I32);
8866 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8867 - proto_perl->Tmarkstack);
8868 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8869 - proto_perl->Tmarkstack);
8870 Copy(proto_perl->Tmarkstack, PL_markstack,
8871 PL_markstack_ptr - PL_markstack + 1, I32);
8873 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8874 * NOTE: unlike the others! */
8875 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8876 PL_scopestack_max = proto_perl->Tscopestack_max;
8877 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8878 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8880 /* next push_return() sets PL_retstack[PL_retstack_ix]
8881 * NOTE: unlike the others! */
8882 PL_retstack_ix = proto_perl->Tretstack_ix;
8883 PL_retstack_max = proto_perl->Tretstack_max;
8884 Newz(54, PL_retstack, PL_retstack_max, OP*);
8885 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8887 /* NOTE: si_dup() looks at PL_markstack */
8888 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8890 /* PL_curstack = PL_curstackinfo->si_stack; */
8891 PL_curstack = av_dup(proto_perl->Tcurstack);
8892 PL_mainstack = av_dup(proto_perl->Tmainstack);
8894 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8895 PL_stack_base = AvARRAY(PL_curstack);
8896 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8897 - proto_perl->Tstack_base);
8898 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8900 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8901 * NOTE: unlike the others! */
8902 PL_savestack_ix = proto_perl->Tsavestack_ix;
8903 PL_savestack_max = proto_perl->Tsavestack_max;
8904 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8905 PL_savestack = ss_dup(proto_perl);
8909 ENTER; /* perl_destruct() wants to LEAVE; */
8912 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8913 PL_top_env = &PL_start_env;
8915 PL_op = proto_perl->Top;
8918 PL_Xpv = (XPV*)NULL;
8919 PL_na = proto_perl->Tna;
8921 PL_statbuf = proto_perl->Tstatbuf;
8922 PL_statcache = proto_perl->Tstatcache;
8923 PL_statgv = gv_dup(proto_perl->Tstatgv);
8924 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8926 PL_timesbuf = proto_perl->Ttimesbuf;
8929 PL_tainted = proto_perl->Ttainted;
8930 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8931 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8932 PL_rs = sv_dup_inc(proto_perl->Trs);
8933 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8934 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
8935 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8936 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8937 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8938 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8939 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8941 PL_restartop = proto_perl->Trestartop;
8942 PL_in_eval = proto_perl->Tin_eval;
8943 PL_delaymagic = proto_perl->Tdelaymagic;
8944 PL_dirty = proto_perl->Tdirty;
8945 PL_localizing = proto_perl->Tlocalizing;
8947 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8948 PL_protect = proto_perl->Tprotect;
8950 PL_errors = sv_dup_inc(proto_perl->Terrors);
8951 PL_av_fetch_sv = Nullsv;
8952 PL_hv_fetch_sv = Nullsv;
8953 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8954 PL_modcount = proto_perl->Tmodcount;
8955 PL_lastgotoprobe = Nullop;
8956 PL_dumpindent = proto_perl->Tdumpindent;
8958 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8959 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8960 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8961 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8962 PL_sortcxix = proto_perl->Tsortcxix;
8963 PL_efloatbuf = Nullch; /* reinits on demand */
8964 PL_efloatsize = 0; /* reinits on demand */
8968 PL_screamfirst = NULL;
8969 PL_screamnext = NULL;
8970 PL_maxscream = -1; /* reinits on demand */
8971 PL_lastscream = Nullsv;
8973 PL_watchaddr = NULL;
8974 PL_watchok = Nullch;
8976 PL_regdummy = proto_perl->Tregdummy;
8977 PL_regcomp_parse = Nullch;
8978 PL_regxend = Nullch;
8979 PL_regcode = (regnode*)NULL;
8982 PL_regprecomp = Nullch;
8987 PL_seen_zerolen = 0;
8989 PL_regcomp_rx = (regexp*)NULL;
8991 PL_colorset = 0; /* reinits PL_colors[] */
8992 /*PL_colors[6] = {0,0,0,0,0,0};*/
8993 PL_reg_whilem_seen = 0;
8994 PL_reginput = Nullch;
8997 PL_regstartp = (I32*)NULL;
8998 PL_regendp = (I32*)NULL;
8999 PL_reglastparen = (U32*)NULL;
9000 PL_regtill = Nullch;
9002 PL_reg_start_tmp = (char**)NULL;
9003 PL_reg_start_tmpl = 0;
9004 PL_regdata = (struct reg_data*)NULL;
9007 PL_reg_eval_set = 0;
9009 PL_regprogram = (regnode*)NULL;
9011 PL_regcc = (CURCUR*)NULL;
9012 PL_reg_call_cc = (struct re_cc_state*)NULL;
9013 PL_reg_re = (regexp*)NULL;
9014 PL_reg_ganch = Nullch;
9016 PL_reg_magic = (MAGIC*)NULL;
9018 PL_reg_oldcurpm = (PMOP*)NULL;
9019 PL_reg_curpm = (PMOP*)NULL;
9020 PL_reg_oldsaved = Nullch;
9021 PL_reg_oldsavedlen = 0;
9023 PL_reg_leftiter = 0;
9024 PL_reg_poscache = Nullch;
9025 PL_reg_poscache_size= 0;
9027 /* RE engine - function pointers */
9028 PL_regcompp = proto_perl->Tregcompp;
9029 PL_regexecp = proto_perl->Tregexecp;
9030 PL_regint_start = proto_perl->Tregint_start;
9031 PL_regint_string = proto_perl->Tregint_string;
9032 PL_regfree = proto_perl->Tregfree;
9034 PL_reginterp_cnt = 0;
9035 PL_reg_starttry = 0;
9038 return (PerlInterpreter*)pPerl;
9044 #else /* !USE_ITHREADS */
9050 #endif /* USE_ITHREADS */
9053 do_report_used(pTHXo_ SV *sv)
9055 if (SvTYPE(sv) != SVTYPEMASK) {
9056 PerlIO_printf(Perl_debug_log, "****\n");
9062 do_clean_objs(pTHXo_ SV *sv)
9066 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9067 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9068 if (SvWEAKREF(sv)) {
9079 /* XXX Might want to check arrays, etc. */
9082 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9084 do_clean_named_objs(pTHXo_ SV *sv)
9086 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9087 if ( SvOBJECT(GvSV(sv)) ||
9088 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9089 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9090 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9091 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9093 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9101 do_clean_all(pTHXo_ SV *sv)
9103 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9104 SvFLAGS(sv) |= SVf_BREAK;