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) || !SvCUR(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(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(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(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 SV
3752 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3758 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3766 if ((spv = SvPV(ssv, slen))) {
3767 bool dutf8 = DO_UTF8(dsv);
3768 bool sutf8 = DO_UTF8(ssv);
3770 if (dutf8 != sutf8) {
3772 char *send = s + slen;
3777 /* We may modify dsv but not ssv. */
3780 sv_utf8_upgrade(dsv);
3781 dpv = SvPV(dsv, dlen);
3782 /* Overguestimate on the slen. */
3783 SvGROW(dsv, dlen + (sutf8 ? 2 * slen : slen) + 1);
3785 if (dutf8) /* && !sutf8 */ {
3787 if (UTF8_IS_ASCII(*s))
3790 *d++ = UTF8_EIGHT_BIT_HI(*s);
3791 *d++ = UTF8_EIGHT_BIT_LO(*s);
3795 SvCUR(dsv) += s - spv;
3798 else /* !dutf8 (was) && sutf8 */ {
3799 sv_catpvn(dsv, spv, slen);
3804 sv_catpvn(dsv, spv, slen);
3810 =for apidoc sv_catsv_mg
3812 Like C<sv_catsv>, but also handles 'set' magic.
3818 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3825 =for apidoc sv_catpv
3827 Concatenates the string onto the end of the string which is in the SV.
3828 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3834 Perl_sv_catpv(pTHX_ register SV *sv, register const char *pv)
3836 register STRLEN len;
3842 junk = SvPV_force(sv, tlen);
3844 SvGROW(sv, tlen + len + 1);
3847 Move(pv,SvPVX(sv)+tlen,len+1,char);
3849 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3854 =for apidoc sv_catpv_mg
3856 Like C<sv_catpv>, but also handles 'set' magic.
3862 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *pv)
3869 Perl_newSV(pTHX_ STRLEN len)
3875 sv_upgrade(sv, SVt_PV);
3876 SvGROW(sv, len + 1);
3881 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3884 =for apidoc sv_magic
3886 Adds magic to an SV.
3892 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3896 if (SvREADONLY(sv)) {
3897 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3898 Perl_croak(aTHX_ PL_no_modify);
3900 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3901 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3908 (void)SvUPGRADE(sv, SVt_PVMG);
3910 Newz(702,mg, 1, MAGIC);
3911 mg->mg_moremagic = SvMAGIC(sv);
3914 if (!obj || obj == sv || how == '#' || how == 'r')
3917 mg->mg_obj = SvREFCNT_inc(obj);
3918 mg->mg_flags |= MGf_REFCOUNTED;
3921 mg->mg_len = namlen;
3924 mg->mg_ptr = savepvn(name, namlen);
3925 else if (namlen == HEf_SVKEY)
3926 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3930 mg->mg_virtual = &PL_vtbl_sv;
3933 mg->mg_virtual = &PL_vtbl_amagic;
3936 mg->mg_virtual = &PL_vtbl_amagicelem;
3942 mg->mg_virtual = &PL_vtbl_bm;
3945 mg->mg_virtual = &PL_vtbl_regdata;
3948 mg->mg_virtual = &PL_vtbl_regdatum;
3951 mg->mg_virtual = &PL_vtbl_env;
3954 mg->mg_virtual = &PL_vtbl_fm;
3957 mg->mg_virtual = &PL_vtbl_envelem;
3960 mg->mg_virtual = &PL_vtbl_mglob;
3963 mg->mg_virtual = &PL_vtbl_isa;
3966 mg->mg_virtual = &PL_vtbl_isaelem;
3969 mg->mg_virtual = &PL_vtbl_nkeys;
3976 mg->mg_virtual = &PL_vtbl_dbline;
3980 mg->mg_virtual = &PL_vtbl_mutex;
3982 #endif /* USE_THREADS */
3983 #ifdef USE_LOCALE_COLLATE
3985 mg->mg_virtual = &PL_vtbl_collxfrm;
3987 #endif /* USE_LOCALE_COLLATE */
3989 mg->mg_virtual = &PL_vtbl_pack;
3993 mg->mg_virtual = &PL_vtbl_packelem;
3996 mg->mg_virtual = &PL_vtbl_regexp;
3999 mg->mg_virtual = &PL_vtbl_sig;
4002 mg->mg_virtual = &PL_vtbl_sigelem;
4005 mg->mg_virtual = &PL_vtbl_taint;
4009 mg->mg_virtual = &PL_vtbl_uvar;
4012 mg->mg_virtual = &PL_vtbl_vec;
4015 mg->mg_virtual = &PL_vtbl_substr;
4018 mg->mg_virtual = &PL_vtbl_defelem;
4021 mg->mg_virtual = &PL_vtbl_glob;
4024 mg->mg_virtual = &PL_vtbl_arylen;
4027 mg->mg_virtual = &PL_vtbl_pos;
4030 mg->mg_virtual = &PL_vtbl_backref;
4032 case '~': /* Reserved for use by extensions not perl internals. */
4033 /* Useful for attaching extension internal data to perl vars. */
4034 /* Note that multiple extensions may clash if magical scalars */
4035 /* etc holding private data from one are passed to another. */
4039 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4043 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4047 =for apidoc sv_unmagic
4049 Removes magic from an SV.
4055 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4059 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4062 for (mg = *mgp; mg; mg = *mgp) {
4063 if (mg->mg_type == type) {
4064 MGVTBL* vtbl = mg->mg_virtual;
4065 *mgp = mg->mg_moremagic;
4066 if (vtbl && vtbl->svt_free)
4067 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4068 if (mg->mg_ptr && mg->mg_type != 'g')
4069 if (mg->mg_len >= 0)
4070 Safefree(mg->mg_ptr);
4071 else if (mg->mg_len == HEf_SVKEY)
4072 SvREFCNT_dec((SV*)mg->mg_ptr);
4073 if (mg->mg_flags & MGf_REFCOUNTED)
4074 SvREFCNT_dec(mg->mg_obj);
4078 mgp = &mg->mg_moremagic;
4082 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4089 =for apidoc sv_rvweaken
4097 Perl_sv_rvweaken(pTHX_ SV *sv)
4100 if (!SvOK(sv)) /* let undefs pass */
4103 Perl_croak(aTHX_ "Can't weaken a nonreference");
4104 else if (SvWEAKREF(sv)) {
4105 if (ckWARN(WARN_MISC))
4106 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4110 sv_add_backref(tsv, sv);
4117 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4121 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4122 av = (AV*)mg->mg_obj;
4125 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4126 SvREFCNT_dec(av); /* for sv_magic */
4132 S_sv_del_backref(pTHX_ SV *sv)
4139 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4140 Perl_croak(aTHX_ "panic: del_backref");
4141 av = (AV *)mg->mg_obj;
4146 svp[i] = &PL_sv_undef; /* XXX */
4153 =for apidoc sv_insert
4155 Inserts a string at the specified offset/length within the SV. Similar to
4156 the Perl substr() function.
4162 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4166 register char *midend;
4167 register char *bigend;
4173 Perl_croak(aTHX_ "Can't modify non-existent substring");
4174 SvPV_force(bigstr, curlen);
4175 (void)SvPOK_only_UTF8(bigstr);
4176 if (offset + len > curlen) {
4177 SvGROW(bigstr, offset+len+1);
4178 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4179 SvCUR_set(bigstr, offset+len);
4183 i = littlelen - len;
4184 if (i > 0) { /* string might grow */
4185 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4186 mid = big + offset + len;
4187 midend = bigend = big + SvCUR(bigstr);
4190 while (midend > mid) /* shove everything down */
4191 *--bigend = *--midend;
4192 Move(little,big+offset,littlelen,char);
4198 Move(little,SvPVX(bigstr)+offset,len,char);
4203 big = SvPVX(bigstr);
4206 bigend = big + SvCUR(bigstr);
4208 if (midend > bigend)
4209 Perl_croak(aTHX_ "panic: sv_insert");
4211 if (mid - big > bigend - midend) { /* faster to shorten from end */
4213 Move(little, mid, littlelen,char);
4216 i = bigend - midend;
4218 Move(midend, mid, i,char);
4222 SvCUR_set(bigstr, mid - big);
4225 else if ((i = mid - big)) { /* faster from front */
4226 midend -= littlelen;
4228 sv_chop(bigstr,midend-i);
4233 Move(little, mid, littlelen,char);
4235 else if (littlelen) {
4236 midend -= littlelen;
4237 sv_chop(bigstr,midend);
4238 Move(little,midend,littlelen,char);
4241 sv_chop(bigstr,midend);
4247 =for apidoc sv_replace
4249 Make the first argument a copy of the second, then delete the original.
4255 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4257 U32 refcnt = SvREFCNT(sv);
4258 SV_CHECK_THINKFIRST(sv);
4259 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4260 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4261 if (SvMAGICAL(sv)) {
4265 sv_upgrade(nsv, SVt_PVMG);
4266 SvMAGIC(nsv) = SvMAGIC(sv);
4267 SvFLAGS(nsv) |= SvMAGICAL(sv);
4273 assert(!SvREFCNT(sv));
4274 StructCopy(nsv,sv,SV);
4275 SvREFCNT(sv) = refcnt;
4276 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4281 =for apidoc sv_clear
4283 Clear an SV, making it empty. Does not free the memory used by the SV
4290 Perl_sv_clear(pTHX_ register SV *sv)
4294 assert(SvREFCNT(sv) == 0);
4297 if (PL_defstash) { /* Still have a symbol table? */
4302 Zero(&tmpref, 1, SV);
4303 sv_upgrade(&tmpref, SVt_RV);
4305 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4306 SvREFCNT(&tmpref) = 1;
4309 stash = SvSTASH(sv);
4310 destructor = StashHANDLER(stash,DESTROY);
4313 PUSHSTACKi(PERLSI_DESTROY);
4314 SvRV(&tmpref) = SvREFCNT_inc(sv);
4319 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4325 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4327 del_XRV(SvANY(&tmpref));
4330 if (PL_in_clean_objs)
4331 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4333 /* DESTROY gave object new lease on life */
4339 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4340 SvOBJECT_off(sv); /* Curse the object. */
4341 if (SvTYPE(sv) != SVt_PVIO)
4342 --PL_sv_objcount; /* XXX Might want something more general */
4345 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4348 switch (SvTYPE(sv)) {
4351 IoIFP(sv) != PerlIO_stdin() &&
4352 IoIFP(sv) != PerlIO_stdout() &&
4353 IoIFP(sv) != PerlIO_stderr())
4355 io_close((IO*)sv, FALSE);
4357 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4358 PerlDir_close(IoDIRP(sv));
4359 IoDIRP(sv) = (DIR*)NULL;
4360 Safefree(IoTOP_NAME(sv));
4361 Safefree(IoFMT_NAME(sv));
4362 Safefree(IoBOTTOM_NAME(sv));
4377 SvREFCNT_dec(LvTARG(sv));
4381 Safefree(GvNAME(sv));
4382 /* cannot decrease stash refcount yet, as we might recursively delete
4383 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4384 of stash until current sv is completely gone.
4385 -- JohnPC, 27 Mar 1998 */
4386 stash = GvSTASH(sv);
4392 (void)SvOOK_off(sv);
4400 SvREFCNT_dec(SvRV(sv));
4402 else if (SvPVX(sv) && SvLEN(sv))
4403 Safefree(SvPVX(sv));
4404 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4405 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4417 switch (SvTYPE(sv)) {
4433 del_XPVIV(SvANY(sv));
4436 del_XPVNV(SvANY(sv));
4439 del_XPVMG(SvANY(sv));
4442 del_XPVLV(SvANY(sv));
4445 del_XPVAV(SvANY(sv));
4448 del_XPVHV(SvANY(sv));
4451 del_XPVCV(SvANY(sv));
4454 del_XPVGV(SvANY(sv));
4455 /* code duplication for increased performance. */
4456 SvFLAGS(sv) &= SVf_BREAK;
4457 SvFLAGS(sv) |= SVTYPEMASK;
4458 /* decrease refcount of the stash that owns this GV, if any */
4460 SvREFCNT_dec(stash);
4461 return; /* not break, SvFLAGS reset already happened */
4463 del_XPVBM(SvANY(sv));
4466 del_XPVFM(SvANY(sv));
4469 del_XPVIO(SvANY(sv));
4472 SvFLAGS(sv) &= SVf_BREAK;
4473 SvFLAGS(sv) |= SVTYPEMASK;
4477 Perl_sv_newref(pTHX_ SV *sv)
4480 ATOMIC_INC(SvREFCNT(sv));
4487 Free the memory used by an SV.
4493 Perl_sv_free(pTHX_ SV *sv)
4495 int refcount_is_zero;
4499 if (SvREFCNT(sv) == 0) {
4500 if (SvFLAGS(sv) & SVf_BREAK)
4502 if (PL_in_clean_all) /* All is fair */
4504 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4505 /* make sure SvREFCNT(sv)==0 happens very seldom */
4506 SvREFCNT(sv) = (~(U32)0)/2;
4509 if (ckWARN_d(WARN_INTERNAL))
4510 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4513 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4514 if (!refcount_is_zero)
4518 if (ckWARN_d(WARN_DEBUGGING))
4519 Perl_warner(aTHX_ WARN_DEBUGGING,
4520 "Attempt to free temp prematurely: SV 0x%"UVxf,
4525 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4526 /* make sure SvREFCNT(sv)==0 happens very seldom */
4527 SvREFCNT(sv) = (~(U32)0)/2;
4538 Returns the length of the string in the SV. See also C<SvCUR>.
4544 Perl_sv_len(pTHX_ register SV *sv)
4553 len = mg_length(sv);
4555 junk = SvPV(sv, len);
4560 =for apidoc sv_len_utf8
4562 Returns the number of characters in the string in an SV, counting wide
4563 UTF8 bytes as a single character.
4569 Perl_sv_len_utf8(pTHX_ register SV *sv)
4575 return mg_length(sv);
4579 U8 *s = (U8*)SvPV(sv, len);
4581 return Perl_utf8_length(aTHX_ s, s + len);
4586 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4591 I32 uoffset = *offsetp;
4597 start = s = (U8*)SvPV(sv, len);
4599 while (s < send && uoffset--)
4603 *offsetp = s - start;
4607 while (s < send && ulen--)
4617 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4626 s = (U8*)SvPV(sv, len);
4628 Perl_croak(aTHX_ "panic: bad byte offset");
4629 send = s + *offsetp;
4636 if (ckWARN_d(WARN_UTF8))
4637 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4647 Returns a boolean indicating whether the strings in the two SVs are
4654 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4661 bool pv1tmp = FALSE;
4662 bool pv2tmp = FALSE;
4669 pv1 = SvPV(sv1, cur1);
4676 pv2 = SvPV(sv2, cur2);
4678 /* do not utf8ize the comparands as a side-effect */
4679 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4681 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4685 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4691 eq = memEQ(pv1, pv2, cur1);
4704 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4705 string in C<sv1> is less than, equal to, or greater than the string in
4712 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4717 bool pv1tmp = FALSE;
4718 bool pv2tmp = FALSE;
4725 pv1 = SvPV(sv1, cur1);
4732 pv2 = SvPV(sv2, cur2);
4734 /* do not utf8ize the comparands as a side-effect */
4735 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4737 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4741 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4747 cmp = cur2 ? -1 : 0;
4751 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4754 cmp = retval < 0 ? -1 : 1;
4755 } else if (cur1 == cur2) {
4758 cmp = cur1 < cur2 ? -1 : 1;
4771 =for apidoc sv_cmp_locale
4773 Compares the strings in two SVs in a locale-aware manner. See
4780 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4782 #ifdef USE_LOCALE_COLLATE
4788 if (PL_collation_standard)
4792 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4794 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4796 if (!pv1 || !len1) {
4807 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4810 return retval < 0 ? -1 : 1;
4813 * When the result of collation is equality, that doesn't mean
4814 * that there are no differences -- some locales exclude some
4815 * characters from consideration. So to avoid false equalities,
4816 * we use the raw string as a tiebreaker.
4822 #endif /* USE_LOCALE_COLLATE */
4824 return sv_cmp(sv1, sv2);
4827 #ifdef USE_LOCALE_COLLATE
4829 * Any scalar variable may carry an 'o' magic that contains the
4830 * scalar data of the variable transformed to such a format that
4831 * a normal memory comparison can be used to compare the data
4832 * according to the locale settings.
4835 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4839 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4840 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4845 Safefree(mg->mg_ptr);
4847 if ((xf = mem_collxfrm(s, len, &xlen))) {
4848 if (SvREADONLY(sv)) {
4851 return xf + sizeof(PL_collation_ix);
4854 sv_magic(sv, 0, 'o', 0, 0);
4855 mg = mg_find(sv, 'o');
4868 if (mg && mg->mg_ptr) {
4870 return mg->mg_ptr + sizeof(PL_collation_ix);
4878 #endif /* USE_LOCALE_COLLATE */
4883 Get a line from the filehandle and store it into the SV, optionally
4884 appending to the currently-stored string.
4890 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4894 register STDCHAR rslast;
4895 register STDCHAR *bp;
4899 SV_CHECK_THINKFIRST(sv);
4900 (void)SvUPGRADE(sv, SVt_PV);
4904 if (RsSNARF(PL_rs)) {
4908 else if (RsRECORD(PL_rs)) {
4909 I32 recsize, bytesread;
4912 /* Grab the size of the record we're getting */
4913 recsize = SvIV(SvRV(PL_rs));
4914 (void)SvPOK_only(sv); /* Validate pointer */
4915 buffer = SvGROW(sv, recsize + 1);
4918 /* VMS wants read instead of fread, because fread doesn't respect */
4919 /* RMS record boundaries. This is not necessarily a good thing to be */
4920 /* doing, but we've got no other real choice */
4921 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4923 bytesread = PerlIO_read(fp, buffer, recsize);
4925 SvCUR_set(sv, bytesread);
4926 buffer[bytesread] = '\0';
4927 if (PerlIO_isutf8(fp))
4931 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4933 else if (RsPARA(PL_rs)) {
4938 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4939 if (PerlIO_isutf8(fp)) {
4940 rsptr = SvPVutf8(PL_rs, rslen);
4943 if (SvUTF8(PL_rs)) {
4944 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4945 Perl_croak(aTHX_ "Wide character in $/");
4948 rsptr = SvPV(PL_rs, rslen);
4952 rslast = rslen ? rsptr[rslen - 1] : '\0';
4954 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4955 do { /* to make sure file boundaries work right */
4958 i = PerlIO_getc(fp);
4962 PerlIO_ungetc(fp,i);
4968 /* See if we know enough about I/O mechanism to cheat it ! */
4970 /* This used to be #ifdef test - it is made run-time test for ease
4971 of abstracting out stdio interface. One call should be cheap
4972 enough here - and may even be a macro allowing compile
4976 if (PerlIO_fast_gets(fp)) {
4979 * We're going to steal some values from the stdio struct
4980 * and put EVERYTHING in the innermost loop into registers.
4982 register STDCHAR *ptr;
4986 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4987 /* An ungetc()d char is handled separately from the regular
4988 * buffer, so we getc() it back out and stuff it in the buffer.
4990 i = PerlIO_getc(fp);
4991 if (i == EOF) return 0;
4992 *(--((*fp)->_ptr)) = (unsigned char) i;
4996 /* Here is some breathtakingly efficient cheating */
4998 cnt = PerlIO_get_cnt(fp); /* get count into register */
4999 (void)SvPOK_only(sv); /* validate pointer */
5000 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5001 if (cnt > 80 && SvLEN(sv) > append) {
5002 shortbuffered = cnt - SvLEN(sv) + append + 1;
5003 cnt -= shortbuffered;
5007 /* remember that cnt can be negative */
5008 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5013 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5014 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5015 DEBUG_P(PerlIO_printf(Perl_debug_log,
5016 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5017 DEBUG_P(PerlIO_printf(Perl_debug_log,
5018 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5019 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5020 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5025 while (cnt > 0) { /* this | eat */
5027 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5028 goto thats_all_folks; /* screams | sed :-) */
5032 Copy(ptr, bp, cnt, char); /* this | eat */
5033 bp += cnt; /* screams | dust */
5034 ptr += cnt; /* louder | sed :-) */
5039 if (shortbuffered) { /* oh well, must extend */
5040 cnt = shortbuffered;
5042 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5044 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5045 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5049 DEBUG_P(PerlIO_printf(Perl_debug_log,
5050 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5051 PTR2UV(ptr),(long)cnt));
5052 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5053 DEBUG_P(PerlIO_printf(Perl_debug_log,
5054 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5055 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5056 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5057 /* This used to call 'filbuf' in stdio form, but as that behaves like
5058 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5059 another abstraction. */
5060 i = PerlIO_getc(fp); /* get more characters */
5061 DEBUG_P(PerlIO_printf(Perl_debug_log,
5062 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5063 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5064 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5065 cnt = PerlIO_get_cnt(fp);
5066 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5067 DEBUG_P(PerlIO_printf(Perl_debug_log,
5068 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5070 if (i == EOF) /* all done for ever? */
5071 goto thats_really_all_folks;
5073 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5075 SvGROW(sv, bpx + cnt + 2);
5076 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5078 *bp++ = i; /* store character from PerlIO_getc */
5080 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5081 goto thats_all_folks;
5085 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5086 memNE((char*)bp - rslen, rsptr, rslen))
5087 goto screamer; /* go back to the fray */
5088 thats_really_all_folks:
5090 cnt += shortbuffered;
5091 DEBUG_P(PerlIO_printf(Perl_debug_log,
5092 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5093 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5094 DEBUG_P(PerlIO_printf(Perl_debug_log,
5095 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5096 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5097 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5099 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5100 DEBUG_P(PerlIO_printf(Perl_debug_log,
5101 "Screamer: done, len=%ld, string=|%.*s|\n",
5102 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5107 /*The big, slow, and stupid way */
5110 /* Need to work around EPOC SDK features */
5111 /* On WINS: MS VC5 generates calls to _chkstk, */
5112 /* if a `large' stack frame is allocated */
5113 /* gcc on MARM does not generate calls like these */
5119 register STDCHAR *bpe = buf + sizeof(buf);
5121 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5122 ; /* keep reading */
5126 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5127 /* Accomodate broken VAXC compiler, which applies U8 cast to
5128 * both args of ?: operator, causing EOF to change into 255
5130 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5134 sv_catpvn(sv, (char *) buf, cnt);
5136 sv_setpvn(sv, (char *) buf, cnt);
5138 if (i != EOF && /* joy */
5140 SvCUR(sv) < rslen ||
5141 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5145 * If we're reading from a TTY and we get a short read,
5146 * indicating that the user hit his EOF character, we need
5147 * to notice it now, because if we try to read from the TTY
5148 * again, the EOF condition will disappear.
5150 * The comparison of cnt to sizeof(buf) is an optimization
5151 * that prevents unnecessary calls to feof().
5155 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5160 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5161 while (i != EOF) { /* to make sure file boundaries work right */
5162 i = PerlIO_getc(fp);
5164 PerlIO_ungetc(fp,i);
5170 if (PerlIO_isutf8(fp))
5175 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5182 Auto-increment of the value in the SV.
5188 Perl_sv_inc(pTHX_ register SV *sv)
5197 if (SvTHINKFIRST(sv)) {
5198 if (SvREADONLY(sv)) {
5199 if (PL_curcop != &PL_compiling)
5200 Perl_croak(aTHX_ PL_no_modify);
5204 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5206 i = PTR2IV(SvRV(sv));
5211 flags = SvFLAGS(sv);
5212 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5213 /* It's (privately or publicly) a float, but not tested as an
5214 integer, so test it to see. */
5216 flags = SvFLAGS(sv);
5218 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5219 /* It's publicly an integer, or privately an integer-not-float */
5222 if (SvUVX(sv) == UV_MAX)
5223 sv_setnv(sv, (NV)UV_MAX + 1.0);
5225 (void)SvIOK_only_UV(sv);
5228 if (SvIVX(sv) == IV_MAX)
5229 sv_setuv(sv, (UV)IV_MAX + 1);
5231 (void)SvIOK_only(sv);
5237 if (flags & SVp_NOK) {
5238 (void)SvNOK_only(sv);
5243 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5244 if ((flags & SVTYPEMASK) < SVt_PVIV)
5245 sv_upgrade(sv, SVt_IV);
5246 (void)SvIOK_only(sv);
5251 while (isALPHA(*d)) d++;
5252 while (isDIGIT(*d)) d++;
5254 #ifdef PERL_PRESERVE_IVUV
5255 /* Got to punt this an an integer if needs be, but we don't issue
5256 warnings. Probably ought to make the sv_iv_please() that does
5257 the conversion if possible, and silently. */
5258 I32 numtype = looks_like_number(sv);
5259 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5260 /* Need to try really hard to see if it's an integer.
5261 9.22337203685478e+18 is an integer.
5262 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5263 so $a="9.22337203685478e+18"; $a+0; $a++
5264 needs to be the same as $a="9.22337203685478e+18"; $a++
5271 /* sv_2iv *should* have made this an NV */
5272 if (flags & SVp_NOK) {
5273 (void)SvNOK_only(sv);
5277 /* I don't think we can get here. Maybe I should assert this
5278 And if we do get here I suspect that sv_setnv will croak. NWC
5280 #if defined(USE_LONG_DOUBLE)
5281 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",
5282 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5284 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5285 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5288 #endif /* PERL_PRESERVE_IVUV */
5289 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5293 while (d >= SvPVX(sv)) {
5301 /* MKS: The original code here died if letters weren't consecutive.
5302 * at least it didn't have to worry about non-C locales. The
5303 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5304 * arranged in order (although not consecutively) and that only
5305 * [A-Za-z] are accepted by isALPHA in the C locale.
5307 if (*d != 'z' && *d != 'Z') {
5308 do { ++*d; } while (!isALPHA(*d));
5311 *(d--) -= 'z' - 'a';
5316 *(d--) -= 'z' - 'a' + 1;
5320 /* oh,oh, the number grew */
5321 SvGROW(sv, SvCUR(sv) + 2);
5323 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5334 Auto-decrement of the value in the SV.
5340 Perl_sv_dec(pTHX_ register SV *sv)
5348 if (SvTHINKFIRST(sv)) {
5349 if (SvREADONLY(sv)) {
5350 if (PL_curcop != &PL_compiling)
5351 Perl_croak(aTHX_ PL_no_modify);
5355 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5357 i = PTR2IV(SvRV(sv));
5362 /* Unlike sv_inc we don't have to worry about string-never-numbers
5363 and keeping them magic. But we mustn't warn on punting */
5364 flags = SvFLAGS(sv);
5365 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5366 /* It's publicly an integer, or privately an integer-not-float */
5369 if (SvUVX(sv) == 0) {
5370 (void)SvIOK_only(sv);
5374 (void)SvIOK_only_UV(sv);
5378 if (SvIVX(sv) == IV_MIN)
5379 sv_setnv(sv, (NV)IV_MIN - 1.0);
5381 (void)SvIOK_only(sv);
5387 if (flags & SVp_NOK) {
5389 (void)SvNOK_only(sv);
5392 if (!(flags & SVp_POK)) {
5393 if ((flags & SVTYPEMASK) < SVt_PVNV)
5394 sv_upgrade(sv, SVt_NV);
5396 (void)SvNOK_only(sv);
5399 #ifdef PERL_PRESERVE_IVUV
5401 I32 numtype = looks_like_number(sv);
5402 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5403 /* Need to try really hard to see if it's an integer.
5404 9.22337203685478e+18 is an integer.
5405 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5406 so $a="9.22337203685478e+18"; $a+0; $a--
5407 needs to be the same as $a="9.22337203685478e+18"; $a--
5414 /* sv_2iv *should* have made this an NV */
5415 if (flags & SVp_NOK) {
5416 (void)SvNOK_only(sv);
5420 /* I don't think we can get here. Maybe I should assert this
5421 And if we do get here I suspect that sv_setnv will croak. NWC
5423 #if defined(USE_LONG_DOUBLE)
5424 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",
5425 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5427 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5428 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5432 #endif /* PERL_PRESERVE_IVUV */
5433 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5437 =for apidoc sv_mortalcopy
5439 Creates a new SV which is a copy of the original SV. The new SV is marked
5445 /* Make a string that will exist for the duration of the expression
5446 * evaluation. Actually, it may have to last longer than that, but
5447 * hopefully we won't free it until it has been assigned to a
5448 * permanent location. */
5451 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5456 sv_setsv(sv,oldstr);
5458 PL_tmps_stack[++PL_tmps_ix] = sv;
5464 =for apidoc sv_newmortal
5466 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5472 Perl_sv_newmortal(pTHX)
5477 SvFLAGS(sv) = SVs_TEMP;
5479 PL_tmps_stack[++PL_tmps_ix] = sv;
5484 =for apidoc sv_2mortal
5486 Marks an SV as mortal. The SV will be destroyed when the current context
5492 /* same thing without the copying */
5495 Perl_sv_2mortal(pTHX_ register SV *sv)
5499 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5502 PL_tmps_stack[++PL_tmps_ix] = sv;
5510 Creates a new SV and copies a string into it. The reference count for the
5511 SV is set to 1. If C<len> is zero, Perl will compute the length using
5512 strlen(). For efficiency, consider using C<newSVpvn> instead.
5518 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5525 sv_setpvn(sv,s,len);
5530 =for apidoc newSVpvn
5532 Creates a new SV and copies a string into it. The reference count for the
5533 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5534 string. You are responsible for ensuring that the source string is at least
5541 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5546 sv_setpvn(sv,s,len);
5551 =for apidoc newSVpvn_share
5553 Creates a new SV and populates it with a string from
5554 the string table. Turns on READONLY and FAKE.
5555 The idea here is that as string table is used for shared hash
5556 keys these strings will have SvPVX == HeKEY and hash lookup
5557 will avoid string compare.
5563 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5566 bool is_utf8 = FALSE;
5572 PERL_HASH(hash, src, len);
5574 sv_upgrade(sv, SVt_PVIV);
5575 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5587 #if defined(PERL_IMPLICIT_CONTEXT)
5589 Perl_newSVpvf_nocontext(const char* pat, ...)
5594 va_start(args, pat);
5595 sv = vnewSVpvf(pat, &args);
5602 =for apidoc newSVpvf
5604 Creates a new SV an initialize it with the string formatted like
5611 Perl_newSVpvf(pTHX_ const char* pat, ...)
5615 va_start(args, pat);
5616 sv = vnewSVpvf(pat, &args);
5622 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5626 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5633 Creates a new SV and copies a floating point value into it.
5634 The reference count for the SV is set to 1.
5640 Perl_newSVnv(pTHX_ NV n)
5652 Creates a new SV and copies an integer into it. The reference count for the
5659 Perl_newSViv(pTHX_ IV i)
5671 Creates a new SV and copies an unsigned integer into it.
5672 The reference count for the SV is set to 1.
5678 Perl_newSVuv(pTHX_ UV u)
5688 =for apidoc newRV_noinc
5690 Creates an RV wrapper for an SV. The reference count for the original
5691 SV is B<not> incremented.
5697 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5702 sv_upgrade(sv, SVt_RV);
5709 /* newRV_inc is #defined to newRV in sv.h */
5711 Perl_newRV(pTHX_ SV *tmpRef)
5713 return newRV_noinc(SvREFCNT_inc(tmpRef));
5719 Creates a new SV which is an exact duplicate of the original SV.
5724 /* make an exact duplicate of old */
5727 Perl_newSVsv(pTHX_ register SV *old)
5733 if (SvTYPE(old) == SVTYPEMASK) {
5734 if (ckWARN_d(WARN_INTERNAL))
5735 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5750 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5758 char todo[PERL_UCHAR_MAX+1];
5763 if (!*s) { /* reset ?? searches */
5764 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5765 pm->op_pmdynflags &= ~PMdf_USED;
5770 /* reset variables */
5772 if (!HvARRAY(stash))
5775 Zero(todo, 256, char);
5777 i = (unsigned char)*s;
5781 max = (unsigned char)*s++;
5782 for ( ; i <= max; i++) {
5785 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5786 for (entry = HvARRAY(stash)[i];
5788 entry = HeNEXT(entry))
5790 if (!todo[(U8)*HeKEY(entry)])
5792 gv = (GV*)HeVAL(entry);
5794 if (SvTHINKFIRST(sv)) {
5795 if (!SvREADONLY(sv) && SvROK(sv))
5800 if (SvTYPE(sv) >= SVt_PV) {
5802 if (SvPVX(sv) != Nullch)
5809 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5811 #ifdef USE_ENVIRON_ARRAY
5813 environ[0] = Nullch;
5822 Perl_sv_2io(pTHX_ SV *sv)
5828 switch (SvTYPE(sv)) {
5836 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5840 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5842 return sv_2io(SvRV(sv));
5843 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5849 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5856 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5863 return *gvp = Nullgv, Nullcv;
5864 switch (SvTYPE(sv)) {
5883 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5884 tryAMAGICunDEREF(to_cv);
5887 if (SvTYPE(sv) == SVt_PVCV) {
5896 Perl_croak(aTHX_ "Not a subroutine reference");
5901 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5907 if (lref && !GvCVu(gv)) {
5910 tmpsv = NEWSV(704,0);
5911 gv_efullname3(tmpsv, gv, Nullch);
5912 /* XXX this is probably not what they think they're getting.
5913 * It has the same effect as "sub name;", i.e. just a forward
5915 newSUB(start_subparse(FALSE, 0),
5916 newSVOP(OP_CONST, 0, tmpsv),
5921 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5930 Returns true if the SV has a true value by Perl's rules.
5936 Perl_sv_true(pTHX_ register SV *sv)
5942 if ((tXpv = (XPV*)SvANY(sv)) &&
5943 (tXpv->xpv_cur > 1 ||
5944 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5951 return SvIVX(sv) != 0;
5954 return SvNVX(sv) != 0.0;
5956 return sv_2bool(sv);
5962 Perl_sv_iv(pTHX_ register SV *sv)
5966 return (IV)SvUVX(sv);
5973 Perl_sv_uv(pTHX_ register SV *sv)
5978 return (UV)SvIVX(sv);
5984 Perl_sv_nv(pTHX_ register SV *sv)
5992 Perl_sv_pv(pTHX_ SV *sv)
5999 return sv_2pv(sv, &n_a);
6003 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6009 return sv_2pv(sv, lp);
6013 =for apidoc sv_pvn_force
6015 Get a sensible string out of the SV somehow.
6021 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6025 if (SvTHINKFIRST(sv) && !SvROK(sv))
6026 sv_force_normal(sv);
6032 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6033 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6034 PL_op_name[PL_op->op_type]);
6038 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6043 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6044 SvGROW(sv, len + 1);
6045 Move(s,SvPVX(sv),len,char);
6050 SvPOK_on(sv); /* validate pointer */
6052 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6053 PTR2UV(sv),SvPVX(sv)));
6060 Perl_sv_pvbyte(pTHX_ SV *sv)
6066 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6068 return sv_pvn(sv,lp);
6072 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6074 return sv_pvn_force(sv,lp);
6078 Perl_sv_pvutf8(pTHX_ SV *sv)
6080 sv_utf8_upgrade(sv);
6085 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6087 sv_utf8_upgrade(sv);
6088 return sv_pvn(sv,lp);
6092 =for apidoc sv_pvutf8n_force
6094 Get a sensible UTF8-encoded string out of the SV somehow. See
6101 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6103 sv_utf8_upgrade(sv);
6104 return sv_pvn_force(sv,lp);
6108 =for apidoc sv_reftype
6110 Returns a string describing what the SV is a reference to.
6116 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6118 if (ob && SvOBJECT(sv))
6119 return HvNAME(SvSTASH(sv));
6121 switch (SvTYPE(sv)) {
6135 case SVt_PVLV: return "LVALUE";
6136 case SVt_PVAV: return "ARRAY";
6137 case SVt_PVHV: return "HASH";
6138 case SVt_PVCV: return "CODE";
6139 case SVt_PVGV: return "GLOB";
6140 case SVt_PVFM: return "FORMAT";
6141 case SVt_PVIO: return "IO";
6142 default: return "UNKNOWN";
6148 =for apidoc sv_isobject
6150 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6151 object. If the SV is not an RV, or if the object is not blessed, then this
6158 Perl_sv_isobject(pTHX_ SV *sv)
6175 Returns a boolean indicating whether the SV is blessed into the specified
6176 class. This does not check for subtypes; use C<sv_derived_from> to verify
6177 an inheritance relationship.
6183 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6195 return strEQ(HvNAME(SvSTASH(sv)), name);
6201 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6202 it will be upgraded to one. If C<classname> is non-null then the new SV will
6203 be blessed in the specified package. The new SV is returned and its
6204 reference count is 1.
6210 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6216 SV_CHECK_THINKFIRST(rv);
6219 if (SvTYPE(rv) >= SVt_PVMG) {
6220 U32 refcnt = SvREFCNT(rv);
6224 SvREFCNT(rv) = refcnt;
6227 if (SvTYPE(rv) < SVt_RV)
6228 sv_upgrade(rv, SVt_RV);
6229 else if (SvTYPE(rv) > SVt_RV) {
6230 (void)SvOOK_off(rv);
6231 if (SvPVX(rv) && SvLEN(rv))
6232 Safefree(SvPVX(rv));
6242 HV* stash = gv_stashpv(classname, TRUE);
6243 (void)sv_bless(rv, stash);
6249 =for apidoc sv_setref_pv
6251 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6252 argument will be upgraded to an RV. That RV will be modified to point to
6253 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6254 into the SV. The C<classname> argument indicates the package for the
6255 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6256 will be returned and will have a reference count of 1.
6258 Do not use with other Perl types such as HV, AV, SV, CV, because those
6259 objects will become corrupted by the pointer copy process.
6261 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6267 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6270 sv_setsv(rv, &PL_sv_undef);
6274 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6279 =for apidoc sv_setref_iv
6281 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6282 argument will be upgraded to an RV. That RV will be modified to point to
6283 the new SV. The C<classname> argument indicates the package for the
6284 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6285 will be returned and will have a reference count of 1.
6291 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6293 sv_setiv(newSVrv(rv,classname), iv);
6298 =for apidoc sv_setref_nv
6300 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6301 argument will be upgraded to an RV. That RV will be modified to point to
6302 the new SV. The C<classname> argument indicates the package for the
6303 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6304 will be returned and will have a reference count of 1.
6310 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6312 sv_setnv(newSVrv(rv,classname), nv);
6317 =for apidoc sv_setref_pvn
6319 Copies a string into a new SV, optionally blessing the SV. The length of the
6320 string must be specified with C<n>. The C<rv> argument will be upgraded to
6321 an RV. That RV will be modified to point to the new SV. The C<classname>
6322 argument indicates the package for the blessing. Set C<classname> to
6323 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6324 a reference count of 1.
6326 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6332 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6334 sv_setpvn(newSVrv(rv,classname), pv, n);
6339 =for apidoc sv_bless
6341 Blesses an SV into a specified package. The SV must be an RV. The package
6342 must be designated by its stash (see C<gv_stashpv()>). The reference count
6343 of the SV is unaffected.
6349 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6353 Perl_croak(aTHX_ "Can't bless non-reference value");
6355 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6356 if (SvREADONLY(tmpRef))
6357 Perl_croak(aTHX_ PL_no_modify);
6358 if (SvOBJECT(tmpRef)) {
6359 if (SvTYPE(tmpRef) != SVt_PVIO)
6361 SvREFCNT_dec(SvSTASH(tmpRef));
6364 SvOBJECT_on(tmpRef);
6365 if (SvTYPE(tmpRef) != SVt_PVIO)
6367 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6368 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6379 S_sv_unglob(pTHX_ SV *sv)
6383 assert(SvTYPE(sv) == SVt_PVGV);
6388 SvREFCNT_dec(GvSTASH(sv));
6389 GvSTASH(sv) = Nullhv;
6391 sv_unmagic(sv, '*');
6392 Safefree(GvNAME(sv));
6395 /* need to keep SvANY(sv) in the right arena */
6396 xpvmg = new_XPVMG();
6397 StructCopy(SvANY(sv), xpvmg, XPVMG);
6398 del_XPVGV(SvANY(sv));
6401 SvFLAGS(sv) &= ~SVTYPEMASK;
6402 SvFLAGS(sv) |= SVt_PVMG;
6406 =for apidoc sv_unref_flags
6408 Unsets the RV status of the SV, and decrements the reference count of
6409 whatever was being referenced by the RV. This can almost be thought of
6410 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6411 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6412 (otherwise the decrementing is conditional on the reference count being
6413 different from one or the reference being a readonly SV).
6420 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6424 if (SvWEAKREF(sv)) {
6432 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6434 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6435 sv_2mortal(rv); /* Schedule for freeing later */
6439 =for apidoc sv_unref
6441 Unsets the RV status of the SV, and decrements the reference count of
6442 whatever was being referenced by the RV. This can almost be thought of
6443 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6444 being zero. See C<SvROK_off>.
6450 Perl_sv_unref(pTHX_ SV *sv)
6452 sv_unref_flags(sv, 0);
6456 Perl_sv_taint(pTHX_ SV *sv)
6458 sv_magic((sv), Nullsv, 't', Nullch, 0);
6462 Perl_sv_untaint(pTHX_ SV *sv)
6464 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6465 MAGIC *mg = mg_find(sv, 't');
6472 Perl_sv_tainted(pTHX_ SV *sv)
6474 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6475 MAGIC *mg = mg_find(sv, 't');
6476 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6483 =for apidoc sv_setpviv
6485 Copies an integer into the given SV, also updating its string value.
6486 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6492 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6494 char buf[TYPE_CHARS(UV)];
6496 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6498 sv_setpvn(sv, ptr, ebuf - ptr);
6503 =for apidoc sv_setpviv_mg
6505 Like C<sv_setpviv>, but also handles 'set' magic.
6511 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6513 char buf[TYPE_CHARS(UV)];
6515 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6517 sv_setpvn(sv, ptr, ebuf - ptr);
6521 #if defined(PERL_IMPLICIT_CONTEXT)
6523 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6527 va_start(args, pat);
6528 sv_vsetpvf(sv, pat, &args);
6534 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6538 va_start(args, pat);
6539 sv_vsetpvf_mg(sv, pat, &args);
6545 =for apidoc sv_setpvf
6547 Processes its arguments like C<sprintf> and sets an SV to the formatted
6548 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6554 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6557 va_start(args, pat);
6558 sv_vsetpvf(sv, pat, &args);
6563 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6565 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6569 =for apidoc sv_setpvf_mg
6571 Like C<sv_setpvf>, but also handles 'set' magic.
6577 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6580 va_start(args, pat);
6581 sv_vsetpvf_mg(sv, pat, &args);
6586 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6588 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6592 #if defined(PERL_IMPLICIT_CONTEXT)
6594 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6598 va_start(args, pat);
6599 sv_vcatpvf(sv, pat, &args);
6604 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6608 va_start(args, pat);
6609 sv_vcatpvf_mg(sv, pat, &args);
6615 =for apidoc sv_catpvf
6617 Processes its arguments like C<sprintf> and appends the formatted output
6618 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6619 typically be called after calling this function to handle 'set' magic.
6625 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6628 va_start(args, pat);
6629 sv_vcatpvf(sv, pat, &args);
6634 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6636 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6640 =for apidoc sv_catpvf_mg
6642 Like C<sv_catpvf>, but also handles 'set' magic.
6648 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6651 va_start(args, pat);
6652 sv_vcatpvf_mg(sv, pat, &args);
6657 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6659 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6664 =for apidoc sv_vsetpvfn
6666 Works like C<vcatpvfn> but copies the text into the SV instead of
6673 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6675 sv_setpvn(sv, "", 0);
6676 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6680 =for apidoc sv_vcatpvfn
6682 Processes its arguments like C<vsprintf> and appends the formatted output
6683 to an SV. Uses an array of SVs if the C style variable argument list is
6684 missing (NULL). When running with taint checks enabled, indicates via
6685 C<maybe_tainted> if results are untrustworthy (often due to the use of
6692 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6699 static char nullstr[] = "(null)";
6702 /* no matter what, this is a string now */
6703 (void)SvPV_force(sv, origlen);
6705 /* special-case "", "%s", and "%_" */
6708 if (patlen == 2 && pat[0] == '%') {
6712 char *s = va_arg(*args, char*);
6713 sv_catpv(sv, s ? s : nullstr);
6715 else if (svix < svmax) {
6716 sv_catsv(sv, *svargs);
6717 if (DO_UTF8(*svargs))
6723 argsv = va_arg(*args, SV*);
6724 sv_catsv(sv, argsv);
6729 /* See comment on '_' below */
6734 patend = (char*)pat + patlen;
6735 for (p = (char*)pat; p < patend; p = q) {
6738 bool vectorize = FALSE;
6745 bool has_precis = FALSE;
6747 bool is_utf = FALSE;
6750 U8 utf8buf[UTF8_MAXLEN+1];
6751 STRLEN esignlen = 0;
6753 char *eptr = Nullch;
6755 /* Times 4: a decimal digit takes more than 3 binary digits.
6756 * NV_DIG: mantissa takes than many decimal digits.
6757 * Plus 32: Playing safe. */
6758 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6759 /* large enough for "%#.#f" --chip */
6760 /* what about long double NVs? --jhi */
6763 U8 *vecstr = Null(U8*);
6775 STRLEN dotstrlen = 1;
6776 I32 epix = 0; /* explicit parameter index */
6777 I32 ewix = 0; /* explicit width index */
6778 bool asterisk = FALSE;
6780 for (q = p; q < patend && *q != '%'; ++q) ;
6782 sv_catpvn(sv, p, q - p);
6811 case '*': /* printf("%*vX",":",$ipv6addr) */
6816 vecsv = va_arg(*args, SV*);
6817 else if (svix < svmax)
6818 vecsv = svargs[svix++];
6821 dotstr = SvPVx(vecsv,dotstrlen);
6849 case '1': case '2': case '3':
6850 case '4': case '5': case '6':
6851 case '7': case '8': case '9':
6854 width = width * 10 + (*q++ - '0');
6856 if (asterisk && ewix == 0) {
6861 } else if (epix == 0) {
6873 i = va_arg(*args, int);
6875 i = (ewix ? ewix <= svmax : svix < svmax) ?
6876 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6878 width = (i < 0) ? -i : i;
6887 i = va_arg(*args, int);
6889 i = (ewix ? ewix <= svmax : svix < svmax)
6890 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6891 precis = (i < 0) ? 0 : i;
6897 precis = precis * 10 + (*q++ - '0');
6904 vecsv = va_arg(*args, SV*);
6905 vecstr = (U8*)SvPVx(vecsv,veclen);
6906 utf = DO_UTF8(vecsv);
6908 else if (epix ? epix <= svmax : svix < svmax) {
6909 vecsv = svargs[epix ? epix-1 : svix++];
6910 vecstr = (U8*)SvPVx(vecsv,veclen);
6911 utf = DO_UTF8(vecsv);
6922 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6933 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6934 if (*(q + 1) == 'l') { /* lld, llf */
6961 uv = va_arg(*args, int);
6963 uv = (epix ? epix <= svmax : svix < svmax) ?
6964 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6965 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6966 eptr = (char*)utf8buf;
6967 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6979 eptr = va_arg(*args, char*);
6981 #ifdef MACOS_TRADITIONAL
6982 /* On MacOS, %#s format is used for Pascal strings */
6987 elen = strlen(eptr);
6990 elen = sizeof nullstr - 1;
6993 else if (epix ? epix <= svmax : svix < svmax) {
6994 argsv = svargs[epix ? epix-1 : svix++];
6995 eptr = SvPVx(argsv, elen);
6996 if (DO_UTF8(argsv)) {
6997 if (has_precis && precis < elen) {
6999 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7002 if (width) { /* fudge width (can't fudge elen) */
7003 width += elen - sv_len_utf8(argsv);
7012 * The "%_" hack might have to be changed someday,
7013 * if ISO or ANSI decide to use '_' for something.
7014 * So we keep it hidden from users' code.
7018 argsv = va_arg(*args,SV*);
7019 eptr = SvPVx(argsv, elen);
7025 if (has_precis && elen > precis)
7035 uv = PTR2UV(va_arg(*args, void*));
7037 uv = (epix ? epix <= svmax : svix < svmax) ?
7038 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
7058 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7068 case 'h': iv = (short)va_arg(*args, int); break;
7069 default: iv = va_arg(*args, int); break;
7070 case 'l': iv = va_arg(*args, long); break;
7071 case 'V': iv = va_arg(*args, IV); break;
7073 case 'q': iv = va_arg(*args, Quad_t); break;
7078 iv = (epix ? epix <= svmax : svix < svmax) ?
7079 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
7081 case 'h': iv = (short)iv; break;
7083 case 'l': iv = (long)iv; break;
7086 case 'q': iv = (Quad_t)iv; break;
7093 esignbuf[esignlen++] = plus;
7097 esignbuf[esignlen++] = '-';
7141 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7151 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7152 default: uv = va_arg(*args, unsigned); break;
7153 case 'l': uv = va_arg(*args, unsigned long); break;
7154 case 'V': uv = va_arg(*args, UV); break;
7156 case 'q': uv = va_arg(*args, Quad_t); break;
7161 uv = (epix ? epix <= svmax : svix < svmax) ?
7162 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
7164 case 'h': uv = (unsigned short)uv; break;
7166 case 'l': uv = (unsigned long)uv; break;
7169 case 'q': uv = (Quad_t)uv; break;
7175 eptr = ebuf + sizeof ebuf;
7181 p = (char*)((c == 'X')
7182 ? "0123456789ABCDEF" : "0123456789abcdef");
7188 esignbuf[esignlen++] = '0';
7189 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7195 *--eptr = '0' + dig;
7197 if (alt && *eptr != '0')
7203 *--eptr = '0' + dig;
7206 esignbuf[esignlen++] = '0';
7207 esignbuf[esignlen++] = 'b';
7210 default: /* it had better be ten or less */
7211 #if defined(PERL_Y2KWARN)
7212 if (ckWARN(WARN_Y2K)) {
7214 char *s = SvPV(sv,n);
7215 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7216 && (n == 2 || !isDIGIT(s[n-3])))
7218 Perl_warner(aTHX_ WARN_Y2K,
7219 "Possible Y2K bug: %%%c %s",
7220 c, "format string following '19'");
7226 *--eptr = '0' + dig;
7227 } while (uv /= base);
7230 elen = (ebuf + sizeof ebuf) - eptr;
7233 zeros = precis - elen;
7234 else if (precis == 0 && elen == 1 && *eptr == '0')
7239 /* FLOATING POINT */
7242 c = 'f'; /* maybe %F isn't supported here */
7248 /* This is evil, but floating point is even more evil */
7252 nv = va_arg(*args, NV);
7254 nv = (epix ? epix <= svmax : svix < svmax) ?
7255 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
7258 if (c != 'e' && c != 'E') {
7260 (void)Perl_frexp(nv, &i);
7261 if (i == PERL_INT_MIN)
7262 Perl_die(aTHX_ "panic: frexp");
7264 need = BIT_DIGITS(i);
7266 need += has_precis ? precis : 6; /* known default */
7270 need += 20; /* fudge factor */
7271 if (PL_efloatsize < need) {
7272 Safefree(PL_efloatbuf);
7273 PL_efloatsize = need + 20; /* more fudge */
7274 New(906, PL_efloatbuf, PL_efloatsize, char);
7275 PL_efloatbuf[0] = '\0';
7278 eptr = ebuf + sizeof ebuf;
7281 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7283 /* Copy the one or more characters in a long double
7284 * format before the 'base' ([efgEFG]) character to
7285 * the format string. */
7286 static char const prifldbl[] = PERL_PRIfldbl;
7287 char const *p = prifldbl + sizeof(prifldbl) - 3;
7288 while (p >= prifldbl) { *--eptr = *p--; }
7293 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7298 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7310 /* No taint. Otherwise we are in the strange situation
7311 * where printf() taints but print($float) doesn't.
7313 (void)sprintf(PL_efloatbuf, eptr, nv);
7315 eptr = PL_efloatbuf;
7316 elen = strlen(PL_efloatbuf);
7323 i = SvCUR(sv) - origlen;
7326 case 'h': *(va_arg(*args, short*)) = i; break;
7327 default: *(va_arg(*args, int*)) = i; break;
7328 case 'l': *(va_arg(*args, long*)) = i; break;
7329 case 'V': *(va_arg(*args, IV*)) = i; break;
7331 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7335 else if (epix ? epix <= svmax : svix < svmax)
7336 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
7337 continue; /* not "break" */
7344 if (!args && ckWARN(WARN_PRINTF) &&
7345 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7346 SV *msg = sv_newmortal();
7347 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7348 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7351 Perl_sv_catpvf(aTHX_ msg,
7352 "\"%%%c\"", c & 0xFF);
7354 Perl_sv_catpvf(aTHX_ msg,
7355 "\"%%\\%03"UVof"\"",
7358 sv_catpv(msg, "end of string");
7359 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7362 /* output mangled stuff ... */
7368 /* ... right here, because formatting flags should not apply */
7369 SvGROW(sv, SvCUR(sv) + elen + 1);
7371 memcpy(p, eptr, elen);
7374 SvCUR(sv) = p - SvPVX(sv);
7375 continue; /* not "break" */
7378 have = esignlen + zeros + elen;
7379 need = (have > width ? have : width);
7382 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7384 if (esignlen && fill == '0') {
7385 for (i = 0; i < esignlen; i++)
7389 memset(p, fill, gap);
7392 if (esignlen && fill != '0') {
7393 for (i = 0; i < esignlen; i++)
7397 for (i = zeros; i; i--)
7401 memcpy(p, eptr, elen);
7405 memset(p, ' ', gap);
7410 memcpy(p, dotstr, dotstrlen);
7414 vectorize = FALSE; /* done iterating over vecstr */
7419 SvCUR(sv) = p - SvPVX(sv);
7427 #if defined(USE_ITHREADS)
7429 #if defined(USE_THREADS)
7430 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7433 #ifndef GpREFCNT_inc
7434 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7438 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7439 #define av_dup(s) (AV*)sv_dup((SV*)s)
7440 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7441 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7442 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7443 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7444 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7445 #define io_dup(s) (IO*)sv_dup((SV*)s)
7446 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7447 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7448 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7449 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7450 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7453 Perl_re_dup(pTHX_ REGEXP *r)
7455 /* XXX fix when pmop->op_pmregexp becomes shared */
7456 return ReREFCNT_inc(r);
7460 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7464 return (PerlIO*)NULL;
7466 /* look for it in the table first */
7467 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7471 /* create anew and remember what it is */
7472 ret = PerlIO_fdupopen(aTHX_ fp);
7473 ptr_table_store(PL_ptr_table, fp, ret);
7478 Perl_dirp_dup(pTHX_ DIR *dp)
7487 Perl_gp_dup(pTHX_ GP *gp)
7492 /* look for it in the table first */
7493 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7497 /* create anew and remember what it is */
7498 Newz(0, ret, 1, GP);
7499 ptr_table_store(PL_ptr_table, gp, ret);
7502 ret->gp_refcnt = 0; /* must be before any other dups! */
7503 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7504 ret->gp_io = io_dup_inc(gp->gp_io);
7505 ret->gp_form = cv_dup_inc(gp->gp_form);
7506 ret->gp_av = av_dup_inc(gp->gp_av);
7507 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7508 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7509 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7510 ret->gp_cvgen = gp->gp_cvgen;
7511 ret->gp_flags = gp->gp_flags;
7512 ret->gp_line = gp->gp_line;
7513 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7518 Perl_mg_dup(pTHX_ MAGIC *mg)
7520 MAGIC *mgret = (MAGIC*)NULL;
7523 return (MAGIC*)NULL;
7524 /* look for it in the table first */
7525 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7529 for (; mg; mg = mg->mg_moremagic) {
7531 Newz(0, nmg, 1, MAGIC);
7535 mgprev->mg_moremagic = nmg;
7536 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7537 nmg->mg_private = mg->mg_private;
7538 nmg->mg_type = mg->mg_type;
7539 nmg->mg_flags = mg->mg_flags;
7540 if (mg->mg_type == 'r') {
7541 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7544 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7545 ? sv_dup_inc(mg->mg_obj)
7546 : sv_dup(mg->mg_obj);
7548 nmg->mg_len = mg->mg_len;
7549 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7550 if (mg->mg_ptr && mg->mg_type != 'g') {
7551 if (mg->mg_len >= 0) {
7552 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7553 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7554 AMT *amtp = (AMT*)mg->mg_ptr;
7555 AMT *namtp = (AMT*)nmg->mg_ptr;
7557 for (i = 1; i < NofAMmeth; i++) {
7558 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7562 else if (mg->mg_len == HEf_SVKEY)
7563 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7571 Perl_ptr_table_new(pTHX)
7574 Newz(0, tbl, 1, PTR_TBL_t);
7577 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7582 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7584 PTR_TBL_ENT_t *tblent;
7585 UV hash = PTR2UV(sv);
7587 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7588 for (; tblent; tblent = tblent->next) {
7589 if (tblent->oldval == sv)
7590 return tblent->newval;
7596 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7598 PTR_TBL_ENT_t *tblent, **otblent;
7599 /* XXX this may be pessimal on platforms where pointers aren't good
7600 * hash values e.g. if they grow faster in the most significant
7602 UV hash = PTR2UV(oldv);
7606 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7607 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7608 if (tblent->oldval == oldv) {
7609 tblent->newval = newv;
7614 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7615 tblent->oldval = oldv;
7616 tblent->newval = newv;
7617 tblent->next = *otblent;
7620 if (i && tbl->tbl_items > tbl->tbl_max)
7621 ptr_table_split(tbl);
7625 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7627 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7628 UV oldsize = tbl->tbl_max + 1;
7629 UV newsize = oldsize * 2;
7632 Renew(ary, newsize, PTR_TBL_ENT_t*);
7633 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7634 tbl->tbl_max = --newsize;
7636 for (i=0; i < oldsize; i++, ary++) {
7637 PTR_TBL_ENT_t **curentp, **entp, *ent;
7640 curentp = ary + oldsize;
7641 for (entp = ary, ent = *ary; ent; ent = *entp) {
7642 if ((newsize & PTR2UV(ent->oldval)) != i) {
7644 ent->next = *curentp;
7659 Perl_sv_dup(pTHX_ SV *sstr)
7663 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7665 /* look for it in the table first */
7666 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7670 /* create anew and remember what it is */
7672 ptr_table_store(PL_ptr_table, sstr, dstr);
7675 SvFLAGS(dstr) = SvFLAGS(sstr);
7676 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7677 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7680 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7681 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7682 PL_watch_pvx, SvPVX(sstr));
7685 switch (SvTYPE(sstr)) {
7690 SvANY(dstr) = new_XIV();
7691 SvIVX(dstr) = SvIVX(sstr);
7694 SvANY(dstr) = new_XNV();
7695 SvNVX(dstr) = SvNVX(sstr);
7698 SvANY(dstr) = new_XRV();
7699 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7702 SvANY(dstr) = new_XPV();
7703 SvCUR(dstr) = SvCUR(sstr);
7704 SvLEN(dstr) = SvLEN(sstr);
7706 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7707 else if (SvPVX(sstr) && SvLEN(sstr))
7708 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7710 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7713 SvANY(dstr) = new_XPVIV();
7714 SvCUR(dstr) = SvCUR(sstr);
7715 SvLEN(dstr) = SvLEN(sstr);
7716 SvIVX(dstr) = SvIVX(sstr);
7718 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7719 else if (SvPVX(sstr) && SvLEN(sstr))
7720 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7722 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7725 SvANY(dstr) = new_XPVNV();
7726 SvCUR(dstr) = SvCUR(sstr);
7727 SvLEN(dstr) = SvLEN(sstr);
7728 SvIVX(dstr) = SvIVX(sstr);
7729 SvNVX(dstr) = SvNVX(sstr);
7731 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7732 else if (SvPVX(sstr) && SvLEN(sstr))
7733 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7735 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7738 SvANY(dstr) = new_XPVMG();
7739 SvCUR(dstr) = SvCUR(sstr);
7740 SvLEN(dstr) = SvLEN(sstr);
7741 SvIVX(dstr) = SvIVX(sstr);
7742 SvNVX(dstr) = SvNVX(sstr);
7743 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7744 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7746 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7747 else if (SvPVX(sstr) && SvLEN(sstr))
7748 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7750 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7753 SvANY(dstr) = new_XPVBM();
7754 SvCUR(dstr) = SvCUR(sstr);
7755 SvLEN(dstr) = SvLEN(sstr);
7756 SvIVX(dstr) = SvIVX(sstr);
7757 SvNVX(dstr) = SvNVX(sstr);
7758 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7759 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7761 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7762 else if (SvPVX(sstr) && SvLEN(sstr))
7763 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7765 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7766 BmRARE(dstr) = BmRARE(sstr);
7767 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7768 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7771 SvANY(dstr) = new_XPVLV();
7772 SvCUR(dstr) = SvCUR(sstr);
7773 SvLEN(dstr) = SvLEN(sstr);
7774 SvIVX(dstr) = SvIVX(sstr);
7775 SvNVX(dstr) = SvNVX(sstr);
7776 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7777 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7779 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7780 else if (SvPVX(sstr) && SvLEN(sstr))
7781 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7783 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7784 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7785 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7786 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7787 LvTYPE(dstr) = LvTYPE(sstr);
7790 SvANY(dstr) = new_XPVGV();
7791 SvCUR(dstr) = SvCUR(sstr);
7792 SvLEN(dstr) = SvLEN(sstr);
7793 SvIVX(dstr) = SvIVX(sstr);
7794 SvNVX(dstr) = SvNVX(sstr);
7795 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7796 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7798 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7799 else if (SvPVX(sstr) && SvLEN(sstr))
7800 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7802 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7803 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7804 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7805 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7806 GvFLAGS(dstr) = GvFLAGS(sstr);
7807 GvGP(dstr) = gp_dup(GvGP(sstr));
7808 (void)GpREFCNT_inc(GvGP(dstr));
7811 SvANY(dstr) = new_XPVIO();
7812 SvCUR(dstr) = SvCUR(sstr);
7813 SvLEN(dstr) = SvLEN(sstr);
7814 SvIVX(dstr) = SvIVX(sstr);
7815 SvNVX(dstr) = SvNVX(sstr);
7816 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7817 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7819 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7820 else if (SvPVX(sstr) && SvLEN(sstr))
7821 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7823 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7824 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7825 if (IoOFP(sstr) == IoIFP(sstr))
7826 IoOFP(dstr) = IoIFP(dstr);
7828 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7829 /* PL_rsfp_filters entries have fake IoDIRP() */
7830 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7831 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7833 IoDIRP(dstr) = IoDIRP(sstr);
7834 IoLINES(dstr) = IoLINES(sstr);
7835 IoPAGE(dstr) = IoPAGE(sstr);
7836 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7837 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7838 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7839 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7840 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7841 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7842 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7843 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7844 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7845 IoTYPE(dstr) = IoTYPE(sstr);
7846 IoFLAGS(dstr) = IoFLAGS(sstr);
7849 SvANY(dstr) = new_XPVAV();
7850 SvCUR(dstr) = SvCUR(sstr);
7851 SvLEN(dstr) = SvLEN(sstr);
7852 SvIVX(dstr) = SvIVX(sstr);
7853 SvNVX(dstr) = SvNVX(sstr);
7854 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7855 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7856 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7857 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7858 if (AvARRAY((AV*)sstr)) {
7859 SV **dst_ary, **src_ary;
7860 SSize_t items = AvFILLp((AV*)sstr) + 1;
7862 src_ary = AvARRAY((AV*)sstr);
7863 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7864 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7865 SvPVX(dstr) = (char*)dst_ary;
7866 AvALLOC((AV*)dstr) = dst_ary;
7867 if (AvREAL((AV*)sstr)) {
7869 *dst_ary++ = sv_dup_inc(*src_ary++);
7873 *dst_ary++ = sv_dup(*src_ary++);
7875 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7876 while (items-- > 0) {
7877 *dst_ary++ = &PL_sv_undef;
7881 SvPVX(dstr) = Nullch;
7882 AvALLOC((AV*)dstr) = (SV**)NULL;
7886 SvANY(dstr) = new_XPVHV();
7887 SvCUR(dstr) = SvCUR(sstr);
7888 SvLEN(dstr) = SvLEN(sstr);
7889 SvIVX(dstr) = SvIVX(sstr);
7890 SvNVX(dstr) = SvNVX(sstr);
7891 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7892 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7893 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7894 if (HvARRAY((HV*)sstr)) {
7896 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7897 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7898 Newz(0, dxhv->xhv_array,
7899 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7900 while (i <= sxhv->xhv_max) {
7901 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7902 !!HvSHAREKEYS(sstr));
7905 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7908 SvPVX(dstr) = Nullch;
7909 HvEITER((HV*)dstr) = (HE*)NULL;
7911 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7912 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7915 SvANY(dstr) = new_XPVFM();
7916 FmLINES(dstr) = FmLINES(sstr);
7920 SvANY(dstr) = new_XPVCV();
7922 SvCUR(dstr) = SvCUR(sstr);
7923 SvLEN(dstr) = SvLEN(sstr);
7924 SvIVX(dstr) = SvIVX(sstr);
7925 SvNVX(dstr) = SvNVX(sstr);
7926 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7927 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7928 if (SvPVX(sstr) && SvLEN(sstr))
7929 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7931 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7932 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7933 CvSTART(dstr) = CvSTART(sstr);
7934 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7935 CvXSUB(dstr) = CvXSUB(sstr);
7936 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7937 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7938 CvDEPTH(dstr) = CvDEPTH(sstr);
7939 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7940 /* XXX padlists are real, but pretend to be not */
7941 AvREAL_on(CvPADLIST(sstr));
7942 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7943 AvREAL_off(CvPADLIST(sstr));
7944 AvREAL_off(CvPADLIST(dstr));
7947 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7948 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7949 CvFLAGS(dstr) = CvFLAGS(sstr);
7952 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7956 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7963 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7968 return (PERL_CONTEXT*)NULL;
7970 /* look for it in the table first */
7971 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7975 /* create anew and remember what it is */
7976 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7977 ptr_table_store(PL_ptr_table, cxs, ncxs);
7980 PERL_CONTEXT *cx = &cxs[ix];
7981 PERL_CONTEXT *ncx = &ncxs[ix];
7982 ncx->cx_type = cx->cx_type;
7983 if (CxTYPE(cx) == CXt_SUBST) {
7984 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7987 ncx->blk_oldsp = cx->blk_oldsp;
7988 ncx->blk_oldcop = cx->blk_oldcop;
7989 ncx->blk_oldretsp = cx->blk_oldretsp;
7990 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7991 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7992 ncx->blk_oldpm = cx->blk_oldpm;
7993 ncx->blk_gimme = cx->blk_gimme;
7994 switch (CxTYPE(cx)) {
7996 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7997 ? cv_dup_inc(cx->blk_sub.cv)
7998 : cv_dup(cx->blk_sub.cv));
7999 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8000 ? av_dup_inc(cx->blk_sub.argarray)
8002 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
8003 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8004 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8005 ncx->blk_sub.lval = cx->blk_sub.lval;
8008 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8009 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8010 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8011 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8012 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8015 ncx->blk_loop.label = cx->blk_loop.label;
8016 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8017 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8018 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8019 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8020 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8021 ? cx->blk_loop.iterdata
8022 : gv_dup((GV*)cx->blk_loop.iterdata));
8023 ncx->blk_loop.oldcurpad
8024 = (SV**)ptr_table_fetch(PL_ptr_table,
8025 cx->blk_loop.oldcurpad);
8026 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8027 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8028 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8029 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8030 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8033 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8034 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8035 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8036 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8049 Perl_si_dup(pTHX_ PERL_SI *si)
8054 return (PERL_SI*)NULL;
8056 /* look for it in the table first */
8057 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8061 /* create anew and remember what it is */
8062 Newz(56, nsi, 1, PERL_SI);
8063 ptr_table_store(PL_ptr_table, si, nsi);
8065 nsi->si_stack = av_dup_inc(si->si_stack);
8066 nsi->si_cxix = si->si_cxix;
8067 nsi->si_cxmax = si->si_cxmax;
8068 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8069 nsi->si_type = si->si_type;
8070 nsi->si_prev = si_dup(si->si_prev);
8071 nsi->si_next = si_dup(si->si_next);
8072 nsi->si_markoff = si->si_markoff;
8077 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8078 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8079 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8080 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8081 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8082 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8083 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8084 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8085 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8086 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8087 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8088 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8091 #define pv_dup_inc(p) SAVEPV(p)
8092 #define pv_dup(p) SAVEPV(p)
8093 #define svp_dup_inc(p,pp) any_dup(p,pp)
8096 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8103 /* look for it in the table first */
8104 ret = ptr_table_fetch(PL_ptr_table, v);
8108 /* see if it is part of the interpreter structure */
8109 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8110 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8118 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8120 ANY *ss = proto_perl->Tsavestack;
8121 I32 ix = proto_perl->Tsavestack_ix;
8122 I32 max = proto_perl->Tsavestack_max;
8135 void (*dptr) (void*);
8136 void (*dxptr) (pTHXo_ void*);
8139 Newz(54, nss, max, ANY);
8145 case SAVEt_ITEM: /* normal string */
8146 sv = (SV*)POPPTR(ss,ix);
8147 TOPPTR(nss,ix) = sv_dup_inc(sv);
8148 sv = (SV*)POPPTR(ss,ix);
8149 TOPPTR(nss,ix) = sv_dup_inc(sv);
8151 case SAVEt_SV: /* scalar reference */
8152 sv = (SV*)POPPTR(ss,ix);
8153 TOPPTR(nss,ix) = sv_dup_inc(sv);
8154 gv = (GV*)POPPTR(ss,ix);
8155 TOPPTR(nss,ix) = gv_dup_inc(gv);
8157 case SAVEt_GENERIC_PVREF: /* generic char* */
8158 c = (char*)POPPTR(ss,ix);
8159 TOPPTR(nss,ix) = pv_dup(c);
8160 ptr = POPPTR(ss,ix);
8161 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8163 case SAVEt_GENERIC_SVREF: /* generic sv */
8164 case SAVEt_SVREF: /* scalar reference */
8165 sv = (SV*)POPPTR(ss,ix);
8166 TOPPTR(nss,ix) = sv_dup_inc(sv);
8167 ptr = POPPTR(ss,ix);
8168 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8170 case SAVEt_AV: /* array reference */
8171 av = (AV*)POPPTR(ss,ix);
8172 TOPPTR(nss,ix) = av_dup_inc(av);
8173 gv = (GV*)POPPTR(ss,ix);
8174 TOPPTR(nss,ix) = gv_dup(gv);
8176 case SAVEt_HV: /* hash reference */
8177 hv = (HV*)POPPTR(ss,ix);
8178 TOPPTR(nss,ix) = hv_dup_inc(hv);
8179 gv = (GV*)POPPTR(ss,ix);
8180 TOPPTR(nss,ix) = gv_dup(gv);
8182 case SAVEt_INT: /* int reference */
8183 ptr = POPPTR(ss,ix);
8184 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8185 intval = (int)POPINT(ss,ix);
8186 TOPINT(nss,ix) = intval;
8188 case SAVEt_LONG: /* long reference */
8189 ptr = POPPTR(ss,ix);
8190 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8191 longval = (long)POPLONG(ss,ix);
8192 TOPLONG(nss,ix) = longval;
8194 case SAVEt_I32: /* I32 reference */
8195 case SAVEt_I16: /* I16 reference */
8196 case SAVEt_I8: /* I8 reference */
8197 ptr = POPPTR(ss,ix);
8198 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8202 case SAVEt_IV: /* IV reference */
8203 ptr = POPPTR(ss,ix);
8204 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8208 case SAVEt_SPTR: /* SV* reference */
8209 ptr = POPPTR(ss,ix);
8210 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8211 sv = (SV*)POPPTR(ss,ix);
8212 TOPPTR(nss,ix) = sv_dup(sv);
8214 case SAVEt_VPTR: /* random* reference */
8215 ptr = POPPTR(ss,ix);
8216 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8217 ptr = POPPTR(ss,ix);
8218 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8220 case SAVEt_PPTR: /* char* reference */
8221 ptr = POPPTR(ss,ix);
8222 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8223 c = (char*)POPPTR(ss,ix);
8224 TOPPTR(nss,ix) = pv_dup(c);
8226 case SAVEt_HPTR: /* HV* reference */
8227 ptr = POPPTR(ss,ix);
8228 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8229 hv = (HV*)POPPTR(ss,ix);
8230 TOPPTR(nss,ix) = hv_dup(hv);
8232 case SAVEt_APTR: /* AV* reference */
8233 ptr = POPPTR(ss,ix);
8234 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8235 av = (AV*)POPPTR(ss,ix);
8236 TOPPTR(nss,ix) = av_dup(av);
8239 gv = (GV*)POPPTR(ss,ix);
8240 TOPPTR(nss,ix) = gv_dup(gv);
8242 case SAVEt_GP: /* scalar reference */
8243 gp = (GP*)POPPTR(ss,ix);
8244 TOPPTR(nss,ix) = gp = gp_dup(gp);
8245 (void)GpREFCNT_inc(gp);
8246 gv = (GV*)POPPTR(ss,ix);
8247 TOPPTR(nss,ix) = gv_dup_inc(c);
8248 c = (char*)POPPTR(ss,ix);
8249 TOPPTR(nss,ix) = pv_dup(c);
8256 sv = (SV*)POPPTR(ss,ix);
8257 TOPPTR(nss,ix) = sv_dup_inc(sv);
8260 ptr = POPPTR(ss,ix);
8261 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8262 /* these are assumed to be refcounted properly */
8263 switch (((OP*)ptr)->op_type) {
8270 TOPPTR(nss,ix) = ptr;
8275 TOPPTR(nss,ix) = Nullop;
8280 TOPPTR(nss,ix) = Nullop;
8283 c = (char*)POPPTR(ss,ix);
8284 TOPPTR(nss,ix) = pv_dup_inc(c);
8287 longval = POPLONG(ss,ix);
8288 TOPLONG(nss,ix) = longval;
8291 hv = (HV*)POPPTR(ss,ix);
8292 TOPPTR(nss,ix) = hv_dup_inc(hv);
8293 c = (char*)POPPTR(ss,ix);
8294 TOPPTR(nss,ix) = pv_dup_inc(c);
8298 case SAVEt_DESTRUCTOR:
8299 ptr = POPPTR(ss,ix);
8300 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8301 dptr = POPDPTR(ss,ix);
8302 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8304 case SAVEt_DESTRUCTOR_X:
8305 ptr = POPPTR(ss,ix);
8306 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8307 dxptr = POPDXPTR(ss,ix);
8308 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8310 case SAVEt_REGCONTEXT:
8316 case SAVEt_STACK_POS: /* Position on Perl stack */
8320 case SAVEt_AELEM: /* array element */
8321 sv = (SV*)POPPTR(ss,ix);
8322 TOPPTR(nss,ix) = sv_dup_inc(sv);
8325 av = (AV*)POPPTR(ss,ix);
8326 TOPPTR(nss,ix) = av_dup_inc(av);
8328 case SAVEt_HELEM: /* hash element */
8329 sv = (SV*)POPPTR(ss,ix);
8330 TOPPTR(nss,ix) = sv_dup_inc(sv);
8331 sv = (SV*)POPPTR(ss,ix);
8332 TOPPTR(nss,ix) = sv_dup_inc(sv);
8333 hv = (HV*)POPPTR(ss,ix);
8334 TOPPTR(nss,ix) = hv_dup_inc(hv);
8337 ptr = POPPTR(ss,ix);
8338 TOPPTR(nss,ix) = ptr;
8345 av = (AV*)POPPTR(ss,ix);
8346 TOPPTR(nss,ix) = av_dup(av);
8349 longval = (long)POPLONG(ss,ix);
8350 TOPLONG(nss,ix) = longval;
8351 ptr = POPPTR(ss,ix);
8352 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8353 sv = (SV*)POPPTR(ss,ix);
8354 TOPPTR(nss,ix) = sv_dup(sv);
8357 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8369 perl_clone(PerlInterpreter *proto_perl, UV flags)
8372 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8375 #ifdef PERL_IMPLICIT_SYS
8376 return perl_clone_using(proto_perl, flags,
8378 proto_perl->IMemShared,
8379 proto_perl->IMemParse,
8389 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8390 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8391 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8392 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8393 struct IPerlDir* ipD, struct IPerlSock* ipS,
8394 struct IPerlProc* ipP)
8396 /* XXX many of the string copies here can be optimized if they're
8397 * constants; they need to be allocated as common memory and just
8398 * their pointers copied. */
8402 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8404 PERL_SET_THX(pPerl);
8405 # else /* !PERL_OBJECT */
8406 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8407 PERL_SET_THX(my_perl);
8410 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8415 # else /* !DEBUGGING */
8416 Zero(my_perl, 1, PerlInterpreter);
8417 # endif /* DEBUGGING */
8421 PL_MemShared = ipMS;
8429 # endif /* PERL_OBJECT */
8430 #else /* !PERL_IMPLICIT_SYS */
8432 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8433 PERL_SET_THX(my_perl);
8436 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8441 # else /* !DEBUGGING */
8442 Zero(my_perl, 1, PerlInterpreter);
8443 # endif /* DEBUGGING */
8444 #endif /* PERL_IMPLICIT_SYS */
8447 PL_xiv_arenaroot = NULL;
8449 PL_xnv_arenaroot = NULL;
8451 PL_xrv_arenaroot = NULL;
8453 PL_xpv_arenaroot = NULL;
8455 PL_xpviv_arenaroot = NULL;
8456 PL_xpviv_root = NULL;
8457 PL_xpvnv_arenaroot = NULL;
8458 PL_xpvnv_root = NULL;
8459 PL_xpvcv_arenaroot = NULL;
8460 PL_xpvcv_root = NULL;
8461 PL_xpvav_arenaroot = NULL;
8462 PL_xpvav_root = NULL;
8463 PL_xpvhv_arenaroot = NULL;
8464 PL_xpvhv_root = NULL;
8465 PL_xpvmg_arenaroot = NULL;
8466 PL_xpvmg_root = NULL;
8467 PL_xpvlv_arenaroot = NULL;
8468 PL_xpvlv_root = NULL;
8469 PL_xpvbm_arenaroot = NULL;
8470 PL_xpvbm_root = NULL;
8471 PL_he_arenaroot = NULL;
8473 PL_nice_chunk = NULL;
8474 PL_nice_chunk_size = 0;
8477 PL_sv_root = Nullsv;
8478 PL_sv_arenaroot = Nullsv;
8480 PL_debug = proto_perl->Idebug;
8482 /* create SV map for pointer relocation */
8483 PL_ptr_table = ptr_table_new();
8485 /* initialize these special pointers as early as possible */
8486 SvANY(&PL_sv_undef) = NULL;
8487 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8488 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8489 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8492 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8494 SvANY(&PL_sv_no) = new_XPVNV();
8496 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8497 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8498 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8499 SvCUR(&PL_sv_no) = 0;
8500 SvLEN(&PL_sv_no) = 1;
8501 SvNVX(&PL_sv_no) = 0;
8502 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8505 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8507 SvANY(&PL_sv_yes) = new_XPVNV();
8509 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8510 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8511 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8512 SvCUR(&PL_sv_yes) = 1;
8513 SvLEN(&PL_sv_yes) = 2;
8514 SvNVX(&PL_sv_yes) = 1;
8515 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8517 /* create shared string table */
8518 PL_strtab = newHV();
8519 HvSHAREKEYS_off(PL_strtab);
8520 hv_ksplit(PL_strtab, 512);
8521 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8523 PL_compiling = proto_perl->Icompiling;
8524 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8525 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8526 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8527 if (!specialWARN(PL_compiling.cop_warnings))
8528 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8529 if (!specialCopIO(PL_compiling.cop_io))
8530 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8531 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8533 /* pseudo environmental stuff */
8534 PL_origargc = proto_perl->Iorigargc;
8536 New(0, PL_origargv, i+1, char*);
8537 PL_origargv[i] = '\0';
8539 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8541 PL_envgv = gv_dup(proto_perl->Ienvgv);
8542 PL_incgv = gv_dup(proto_perl->Iincgv);
8543 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8544 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8545 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8546 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8549 PL_minus_c = proto_perl->Iminus_c;
8550 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8551 PL_localpatches = proto_perl->Ilocalpatches;
8552 PL_splitstr = proto_perl->Isplitstr;
8553 PL_preprocess = proto_perl->Ipreprocess;
8554 PL_minus_n = proto_perl->Iminus_n;
8555 PL_minus_p = proto_perl->Iminus_p;
8556 PL_minus_l = proto_perl->Iminus_l;
8557 PL_minus_a = proto_perl->Iminus_a;
8558 PL_minus_F = proto_perl->Iminus_F;
8559 PL_doswitches = proto_perl->Idoswitches;
8560 PL_dowarn = proto_perl->Idowarn;
8561 PL_doextract = proto_perl->Idoextract;
8562 PL_sawampersand = proto_perl->Isawampersand;
8563 PL_unsafe = proto_perl->Iunsafe;
8564 PL_inplace = SAVEPV(proto_perl->Iinplace);
8565 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8566 PL_perldb = proto_perl->Iperldb;
8567 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8569 /* magical thingies */
8570 /* XXX time(&PL_basetime) when asked for? */
8571 PL_basetime = proto_perl->Ibasetime;
8572 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8574 PL_maxsysfd = proto_perl->Imaxsysfd;
8575 PL_multiline = proto_perl->Imultiline;
8576 PL_statusvalue = proto_perl->Istatusvalue;
8578 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8581 /* shortcuts to various I/O objects */
8582 PL_stdingv = gv_dup(proto_perl->Istdingv);
8583 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8584 PL_defgv = gv_dup(proto_perl->Idefgv);
8585 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8586 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8587 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8589 /* shortcuts to regexp stuff */
8590 PL_replgv = gv_dup(proto_perl->Ireplgv);
8592 /* shortcuts to misc objects */
8593 PL_errgv = gv_dup(proto_perl->Ierrgv);
8595 /* shortcuts to debugging objects */
8596 PL_DBgv = gv_dup(proto_perl->IDBgv);
8597 PL_DBline = gv_dup(proto_perl->IDBline);
8598 PL_DBsub = gv_dup(proto_perl->IDBsub);
8599 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8600 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8601 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8602 PL_lineary = av_dup(proto_perl->Ilineary);
8603 PL_dbargs = av_dup(proto_perl->Idbargs);
8606 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8607 PL_curstash = hv_dup(proto_perl->Tcurstash);
8608 PL_debstash = hv_dup(proto_perl->Idebstash);
8609 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8610 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8612 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8613 PL_endav = av_dup_inc(proto_perl->Iendav);
8614 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8615 PL_initav = av_dup_inc(proto_perl->Iinitav);
8617 PL_sub_generation = proto_perl->Isub_generation;
8619 /* funky return mechanisms */
8620 PL_forkprocess = proto_perl->Iforkprocess;
8622 /* subprocess state */
8623 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8625 /* internal state */
8626 PL_tainting = proto_perl->Itainting;
8627 PL_maxo = proto_perl->Imaxo;
8628 if (proto_perl->Iop_mask)
8629 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8631 PL_op_mask = Nullch;
8633 /* current interpreter roots */
8634 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8635 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8636 PL_main_start = proto_perl->Imain_start;
8637 PL_eval_root = proto_perl->Ieval_root;
8638 PL_eval_start = proto_perl->Ieval_start;
8640 /* runtime control stuff */
8641 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8642 PL_copline = proto_perl->Icopline;
8644 PL_filemode = proto_perl->Ifilemode;
8645 PL_lastfd = proto_perl->Ilastfd;
8646 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8649 PL_gensym = proto_perl->Igensym;
8650 PL_preambled = proto_perl->Ipreambled;
8651 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8652 PL_laststatval = proto_perl->Ilaststatval;
8653 PL_laststype = proto_perl->Ilaststype;
8654 PL_mess_sv = Nullsv;
8656 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8657 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8659 /* interpreter atexit processing */
8660 PL_exitlistlen = proto_perl->Iexitlistlen;
8661 if (PL_exitlistlen) {
8662 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8663 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8666 PL_exitlist = (PerlExitListEntry*)NULL;
8667 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8669 PL_profiledata = NULL;
8670 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8671 /* PL_rsfp_filters entries have fake IoDIRP() */
8672 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8674 PL_compcv = cv_dup(proto_perl->Icompcv);
8675 PL_comppad = av_dup(proto_perl->Icomppad);
8676 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8677 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8678 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8679 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8680 proto_perl->Tcurpad);
8682 #ifdef HAVE_INTERP_INTERN
8683 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8686 /* more statics moved here */
8687 PL_generation = proto_perl->Igeneration;
8688 PL_DBcv = cv_dup(proto_perl->IDBcv);
8690 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8691 PL_in_clean_all = proto_perl->Iin_clean_all;
8693 PL_uid = proto_perl->Iuid;
8694 PL_euid = proto_perl->Ieuid;
8695 PL_gid = proto_perl->Igid;
8696 PL_egid = proto_perl->Iegid;
8697 PL_nomemok = proto_perl->Inomemok;
8698 PL_an = proto_perl->Ian;
8699 PL_cop_seqmax = proto_perl->Icop_seqmax;
8700 PL_op_seqmax = proto_perl->Iop_seqmax;
8701 PL_evalseq = proto_perl->Ievalseq;
8702 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8703 PL_origalen = proto_perl->Iorigalen;
8704 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8705 PL_osname = SAVEPV(proto_perl->Iosname);
8706 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8707 PL_sighandlerp = proto_perl->Isighandlerp;
8710 PL_runops = proto_perl->Irunops;
8712 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8715 PL_cshlen = proto_perl->Icshlen;
8716 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8719 PL_lex_state = proto_perl->Ilex_state;
8720 PL_lex_defer = proto_perl->Ilex_defer;
8721 PL_lex_expect = proto_perl->Ilex_expect;
8722 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8723 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8724 PL_lex_starts = proto_perl->Ilex_starts;
8725 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8726 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8727 PL_lex_op = proto_perl->Ilex_op;
8728 PL_lex_inpat = proto_perl->Ilex_inpat;
8729 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8730 PL_lex_brackets = proto_perl->Ilex_brackets;
8731 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8732 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8733 PL_lex_casemods = proto_perl->Ilex_casemods;
8734 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8735 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8737 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8738 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8739 PL_nexttoke = proto_perl->Inexttoke;
8741 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8742 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8743 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8744 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8745 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8746 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8747 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8748 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8749 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8750 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8751 PL_pending_ident = proto_perl->Ipending_ident;
8752 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8754 PL_expect = proto_perl->Iexpect;
8756 PL_multi_start = proto_perl->Imulti_start;
8757 PL_multi_end = proto_perl->Imulti_end;
8758 PL_multi_open = proto_perl->Imulti_open;
8759 PL_multi_close = proto_perl->Imulti_close;
8761 PL_error_count = proto_perl->Ierror_count;
8762 PL_subline = proto_perl->Isubline;
8763 PL_subname = sv_dup_inc(proto_perl->Isubname);
8765 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8766 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8767 PL_padix = proto_perl->Ipadix;
8768 PL_padix_floor = proto_perl->Ipadix_floor;
8769 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8771 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8772 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8773 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8774 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8775 PL_last_lop_op = proto_perl->Ilast_lop_op;
8776 PL_in_my = proto_perl->Iin_my;
8777 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8779 PL_cryptseen = proto_perl->Icryptseen;
8782 PL_hints = proto_perl->Ihints;
8784 PL_amagic_generation = proto_perl->Iamagic_generation;
8786 #ifdef USE_LOCALE_COLLATE
8787 PL_collation_ix = proto_perl->Icollation_ix;
8788 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8789 PL_collation_standard = proto_perl->Icollation_standard;
8790 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8791 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8792 #endif /* USE_LOCALE_COLLATE */
8794 #ifdef USE_LOCALE_NUMERIC
8795 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8796 PL_numeric_standard = proto_perl->Inumeric_standard;
8797 PL_numeric_local = proto_perl->Inumeric_local;
8798 PL_numeric_radix = proto_perl->Inumeric_radix;
8799 #endif /* !USE_LOCALE_NUMERIC */
8801 /* utf8 character classes */
8802 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8803 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8804 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8805 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8806 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8807 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8808 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8809 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8810 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8811 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8812 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8813 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8814 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8815 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8816 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8817 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8818 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8821 PL_last_swash_hv = Nullhv; /* reinits on demand */
8822 PL_last_swash_klen = 0;
8823 PL_last_swash_key[0]= '\0';
8824 PL_last_swash_tmps = (U8*)NULL;
8825 PL_last_swash_slen = 0;
8827 /* perly.c globals */
8828 PL_yydebug = proto_perl->Iyydebug;
8829 PL_yynerrs = proto_perl->Iyynerrs;
8830 PL_yyerrflag = proto_perl->Iyyerrflag;
8831 PL_yychar = proto_perl->Iyychar;
8832 PL_yyval = proto_perl->Iyyval;
8833 PL_yylval = proto_perl->Iyylval;
8835 PL_glob_index = proto_perl->Iglob_index;
8836 PL_srand_called = proto_perl->Isrand_called;
8837 PL_uudmap['M'] = 0; /* reinits on demand */
8838 PL_bitcount = Nullch; /* reinits on demand */
8840 if (proto_perl->Ipsig_ptr) {
8841 int sig_num[] = { SIG_NUM };
8842 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8843 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8844 for (i = 1; PL_sig_name[i]; i++) {
8845 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8846 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8850 PL_psig_ptr = (SV**)NULL;
8851 PL_psig_name = (SV**)NULL;
8854 /* thrdvar.h stuff */
8857 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8858 PL_tmps_ix = proto_perl->Ttmps_ix;
8859 PL_tmps_max = proto_perl->Ttmps_max;
8860 PL_tmps_floor = proto_perl->Ttmps_floor;
8861 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8863 while (i <= PL_tmps_ix) {
8864 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8868 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8869 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8870 Newz(54, PL_markstack, i, I32);
8871 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8872 - proto_perl->Tmarkstack);
8873 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8874 - proto_perl->Tmarkstack);
8875 Copy(proto_perl->Tmarkstack, PL_markstack,
8876 PL_markstack_ptr - PL_markstack + 1, I32);
8878 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8879 * NOTE: unlike the others! */
8880 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8881 PL_scopestack_max = proto_perl->Tscopestack_max;
8882 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8883 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8885 /* next push_return() sets PL_retstack[PL_retstack_ix]
8886 * NOTE: unlike the others! */
8887 PL_retstack_ix = proto_perl->Tretstack_ix;
8888 PL_retstack_max = proto_perl->Tretstack_max;
8889 Newz(54, PL_retstack, PL_retstack_max, OP*);
8890 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8892 /* NOTE: si_dup() looks at PL_markstack */
8893 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8895 /* PL_curstack = PL_curstackinfo->si_stack; */
8896 PL_curstack = av_dup(proto_perl->Tcurstack);
8897 PL_mainstack = av_dup(proto_perl->Tmainstack);
8899 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8900 PL_stack_base = AvARRAY(PL_curstack);
8901 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8902 - proto_perl->Tstack_base);
8903 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8905 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8906 * NOTE: unlike the others! */
8907 PL_savestack_ix = proto_perl->Tsavestack_ix;
8908 PL_savestack_max = proto_perl->Tsavestack_max;
8909 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8910 PL_savestack = ss_dup(proto_perl);
8914 ENTER; /* perl_destruct() wants to LEAVE; */
8917 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8918 PL_top_env = &PL_start_env;
8920 PL_op = proto_perl->Top;
8923 PL_Xpv = (XPV*)NULL;
8924 PL_na = proto_perl->Tna;
8926 PL_statbuf = proto_perl->Tstatbuf;
8927 PL_statcache = proto_perl->Tstatcache;
8928 PL_statgv = gv_dup(proto_perl->Tstatgv);
8929 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8931 PL_timesbuf = proto_perl->Ttimesbuf;
8934 PL_tainted = proto_perl->Ttainted;
8935 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8936 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8937 PL_rs = sv_dup_inc(proto_perl->Trs);
8938 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8939 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
8940 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8941 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8942 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8943 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8944 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8946 PL_restartop = proto_perl->Trestartop;
8947 PL_in_eval = proto_perl->Tin_eval;
8948 PL_delaymagic = proto_perl->Tdelaymagic;
8949 PL_dirty = proto_perl->Tdirty;
8950 PL_localizing = proto_perl->Tlocalizing;
8952 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8953 PL_protect = proto_perl->Tprotect;
8955 PL_errors = sv_dup_inc(proto_perl->Terrors);
8956 PL_av_fetch_sv = Nullsv;
8957 PL_hv_fetch_sv = Nullsv;
8958 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8959 PL_modcount = proto_perl->Tmodcount;
8960 PL_lastgotoprobe = Nullop;
8961 PL_dumpindent = proto_perl->Tdumpindent;
8963 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8964 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8965 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8966 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8967 PL_sortcxix = proto_perl->Tsortcxix;
8968 PL_efloatbuf = Nullch; /* reinits on demand */
8969 PL_efloatsize = 0; /* reinits on demand */
8973 PL_screamfirst = NULL;
8974 PL_screamnext = NULL;
8975 PL_maxscream = -1; /* reinits on demand */
8976 PL_lastscream = Nullsv;
8978 PL_watchaddr = NULL;
8979 PL_watchok = Nullch;
8981 PL_regdummy = proto_perl->Tregdummy;
8982 PL_regcomp_parse = Nullch;
8983 PL_regxend = Nullch;
8984 PL_regcode = (regnode*)NULL;
8987 PL_regprecomp = Nullch;
8992 PL_seen_zerolen = 0;
8994 PL_regcomp_rx = (regexp*)NULL;
8996 PL_colorset = 0; /* reinits PL_colors[] */
8997 /*PL_colors[6] = {0,0,0,0,0,0};*/
8998 PL_reg_whilem_seen = 0;
8999 PL_reginput = Nullch;
9002 PL_regstartp = (I32*)NULL;
9003 PL_regendp = (I32*)NULL;
9004 PL_reglastparen = (U32*)NULL;
9005 PL_regtill = Nullch;
9007 PL_reg_start_tmp = (char**)NULL;
9008 PL_reg_start_tmpl = 0;
9009 PL_regdata = (struct reg_data*)NULL;
9012 PL_reg_eval_set = 0;
9014 PL_regprogram = (regnode*)NULL;
9016 PL_regcc = (CURCUR*)NULL;
9017 PL_reg_call_cc = (struct re_cc_state*)NULL;
9018 PL_reg_re = (regexp*)NULL;
9019 PL_reg_ganch = Nullch;
9021 PL_reg_magic = (MAGIC*)NULL;
9023 PL_reg_oldcurpm = (PMOP*)NULL;
9024 PL_reg_curpm = (PMOP*)NULL;
9025 PL_reg_oldsaved = Nullch;
9026 PL_reg_oldsavedlen = 0;
9028 PL_reg_leftiter = 0;
9029 PL_reg_poscache = Nullch;
9030 PL_reg_poscache_size= 0;
9032 /* RE engine - function pointers */
9033 PL_regcompp = proto_perl->Tregcompp;
9034 PL_regexecp = proto_perl->Tregexecp;
9035 PL_regint_start = proto_perl->Tregint_start;
9036 PL_regint_string = proto_perl->Tregint_string;
9037 PL_regfree = proto_perl->Tregfree;
9039 PL_reginterp_cnt = 0;
9040 PL_reg_starttry = 0;
9043 return (PerlInterpreter*)pPerl;
9049 #else /* !USE_ITHREADS */
9055 #endif /* USE_ITHREADS */
9058 do_report_used(pTHXo_ SV *sv)
9060 if (SvTYPE(sv) != SVTYPEMASK) {
9061 PerlIO_printf(Perl_debug_log, "****\n");
9067 do_clean_objs(pTHXo_ SV *sv)
9071 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9072 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9073 if (SvWEAKREF(sv)) {
9084 /* XXX Might want to check arrays, etc. */
9087 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9089 do_clean_named_objs(pTHXo_ SV *sv)
9091 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9092 if ( SvOBJECT(GvSV(sv)) ||
9093 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9094 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9095 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9096 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9098 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9106 do_clean_all(pTHXo_ SV *sv)
9108 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9109 SvFLAGS(sv) |= SVf_BREAK;