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) {
3775 /* We may modify dsv but not ssv. */
3778 sv_utf8_upgrade(dsv);
3779 dpv = SvPV(dsv, dlen);
3780 /* Overguestimate on the slen. */
3781 /* (Why +2 and not +1 is needed?
3782 * (Try PERL_DESTRUCT_LEVEL=2 ./perl t/op/join.t)
3783 * Can't figure out right now. --jhi) */
3784 SvGROW(dsv, dlen + (sutf8 ? 2 * slen : slen) + 2);
3786 if (dutf8) /* && !sutf8 */ {
3788 char *send = s + slen;
3793 if (UTF8_IS_ASCII(c))
3796 *d++ = UTF8_EIGHT_BIT_HI(c);
3797 *d++ = UTF8_EIGHT_BIT_LO(c);
3798 s++; /* skip the low byte */
3801 SvCUR(dsv) += s - spv;
3804 else /* !dutf8 (was) && sutf8 */ {
3805 sv_catpvn(dsv, spv, slen);
3810 sv_catpvn(dsv, spv, slen);
3816 =for apidoc sv_catsv_mg
3818 Like C<sv_catsv>, but also handles 'set' magic.
3824 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3831 =for apidoc sv_catpv
3833 Concatenates the string onto the end of the string which is in the SV.
3834 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3840 Perl_sv_catpv(pTHX_ register SV *sv, register const char *pv)
3842 register STRLEN len;
3848 junk = SvPV_force(sv, tlen);
3850 SvGROW(sv, tlen + len + 1);
3853 Move(pv,SvPVX(sv)+tlen,len+1,char);
3855 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3860 =for apidoc sv_catpv_mg
3862 Like C<sv_catpv>, but also handles 'set' magic.
3868 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *pv)
3875 Perl_newSV(pTHX_ STRLEN len)
3881 sv_upgrade(sv, SVt_PV);
3882 SvGROW(sv, len + 1);
3887 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3890 =for apidoc sv_magic
3892 Adds magic to an SV.
3898 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3902 if (SvREADONLY(sv)) {
3903 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3904 Perl_croak(aTHX_ PL_no_modify);
3906 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3907 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3914 (void)SvUPGRADE(sv, SVt_PVMG);
3916 Newz(702,mg, 1, MAGIC);
3917 mg->mg_moremagic = SvMAGIC(sv);
3920 if (!obj || obj == sv || how == '#' || how == 'r')
3923 mg->mg_obj = SvREFCNT_inc(obj);
3924 mg->mg_flags |= MGf_REFCOUNTED;
3927 mg->mg_len = namlen;
3930 mg->mg_ptr = savepvn(name, namlen);
3931 else if (namlen == HEf_SVKEY)
3932 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3936 mg->mg_virtual = &PL_vtbl_sv;
3939 mg->mg_virtual = &PL_vtbl_amagic;
3942 mg->mg_virtual = &PL_vtbl_amagicelem;
3948 mg->mg_virtual = &PL_vtbl_bm;
3951 mg->mg_virtual = &PL_vtbl_regdata;
3954 mg->mg_virtual = &PL_vtbl_regdatum;
3957 mg->mg_virtual = &PL_vtbl_env;
3960 mg->mg_virtual = &PL_vtbl_fm;
3963 mg->mg_virtual = &PL_vtbl_envelem;
3966 mg->mg_virtual = &PL_vtbl_mglob;
3969 mg->mg_virtual = &PL_vtbl_isa;
3972 mg->mg_virtual = &PL_vtbl_isaelem;
3975 mg->mg_virtual = &PL_vtbl_nkeys;
3982 mg->mg_virtual = &PL_vtbl_dbline;
3986 mg->mg_virtual = &PL_vtbl_mutex;
3988 #endif /* USE_THREADS */
3989 #ifdef USE_LOCALE_COLLATE
3991 mg->mg_virtual = &PL_vtbl_collxfrm;
3993 #endif /* USE_LOCALE_COLLATE */
3995 mg->mg_virtual = &PL_vtbl_pack;
3999 mg->mg_virtual = &PL_vtbl_packelem;
4002 mg->mg_virtual = &PL_vtbl_regexp;
4005 mg->mg_virtual = &PL_vtbl_sig;
4008 mg->mg_virtual = &PL_vtbl_sigelem;
4011 mg->mg_virtual = &PL_vtbl_taint;
4015 mg->mg_virtual = &PL_vtbl_uvar;
4018 mg->mg_virtual = &PL_vtbl_vec;
4021 mg->mg_virtual = &PL_vtbl_substr;
4024 mg->mg_virtual = &PL_vtbl_defelem;
4027 mg->mg_virtual = &PL_vtbl_glob;
4030 mg->mg_virtual = &PL_vtbl_arylen;
4033 mg->mg_virtual = &PL_vtbl_pos;
4036 mg->mg_virtual = &PL_vtbl_backref;
4038 case '~': /* Reserved for use by extensions not perl internals. */
4039 /* Useful for attaching extension internal data to perl vars. */
4040 /* Note that multiple extensions may clash if magical scalars */
4041 /* etc holding private data from one are passed to another. */
4045 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4049 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4053 =for apidoc sv_unmagic
4055 Removes magic from an SV.
4061 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4065 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4068 for (mg = *mgp; mg; mg = *mgp) {
4069 if (mg->mg_type == type) {
4070 MGVTBL* vtbl = mg->mg_virtual;
4071 *mgp = mg->mg_moremagic;
4072 if (vtbl && vtbl->svt_free)
4073 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4074 if (mg->mg_ptr && mg->mg_type != 'g')
4075 if (mg->mg_len >= 0)
4076 Safefree(mg->mg_ptr);
4077 else if (mg->mg_len == HEf_SVKEY)
4078 SvREFCNT_dec((SV*)mg->mg_ptr);
4079 if (mg->mg_flags & MGf_REFCOUNTED)
4080 SvREFCNT_dec(mg->mg_obj);
4084 mgp = &mg->mg_moremagic;
4088 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4095 =for apidoc sv_rvweaken
4103 Perl_sv_rvweaken(pTHX_ SV *sv)
4106 if (!SvOK(sv)) /* let undefs pass */
4109 Perl_croak(aTHX_ "Can't weaken a nonreference");
4110 else if (SvWEAKREF(sv)) {
4111 if (ckWARN(WARN_MISC))
4112 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4116 sv_add_backref(tsv, sv);
4123 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4127 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4128 av = (AV*)mg->mg_obj;
4131 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4132 SvREFCNT_dec(av); /* for sv_magic */
4138 S_sv_del_backref(pTHX_ SV *sv)
4145 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4146 Perl_croak(aTHX_ "panic: del_backref");
4147 av = (AV *)mg->mg_obj;
4152 svp[i] = &PL_sv_undef; /* XXX */
4159 =for apidoc sv_insert
4161 Inserts a string at the specified offset/length within the SV. Similar to
4162 the Perl substr() function.
4168 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4172 register char *midend;
4173 register char *bigend;
4179 Perl_croak(aTHX_ "Can't modify non-existent substring");
4180 SvPV_force(bigstr, curlen);
4181 (void)SvPOK_only_UTF8(bigstr);
4182 if (offset + len > curlen) {
4183 SvGROW(bigstr, offset+len+1);
4184 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4185 SvCUR_set(bigstr, offset+len);
4189 i = littlelen - len;
4190 if (i > 0) { /* string might grow */
4191 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4192 mid = big + offset + len;
4193 midend = bigend = big + SvCUR(bigstr);
4196 while (midend > mid) /* shove everything down */
4197 *--bigend = *--midend;
4198 Move(little,big+offset,littlelen,char);
4204 Move(little,SvPVX(bigstr)+offset,len,char);
4209 big = SvPVX(bigstr);
4212 bigend = big + SvCUR(bigstr);
4214 if (midend > bigend)
4215 Perl_croak(aTHX_ "panic: sv_insert");
4217 if (mid - big > bigend - midend) { /* faster to shorten from end */
4219 Move(little, mid, littlelen,char);
4222 i = bigend - midend;
4224 Move(midend, mid, i,char);
4228 SvCUR_set(bigstr, mid - big);
4231 else if ((i = mid - big)) { /* faster from front */
4232 midend -= littlelen;
4234 sv_chop(bigstr,midend-i);
4239 Move(little, mid, littlelen,char);
4241 else if (littlelen) {
4242 midend -= littlelen;
4243 sv_chop(bigstr,midend);
4244 Move(little,midend,littlelen,char);
4247 sv_chop(bigstr,midend);
4253 =for apidoc sv_replace
4255 Make the first argument a copy of the second, then delete the original.
4261 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4263 U32 refcnt = SvREFCNT(sv);
4264 SV_CHECK_THINKFIRST(sv);
4265 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4266 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4267 if (SvMAGICAL(sv)) {
4271 sv_upgrade(nsv, SVt_PVMG);
4272 SvMAGIC(nsv) = SvMAGIC(sv);
4273 SvFLAGS(nsv) |= SvMAGICAL(sv);
4279 assert(!SvREFCNT(sv));
4280 StructCopy(nsv,sv,SV);
4281 SvREFCNT(sv) = refcnt;
4282 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4287 =for apidoc sv_clear
4289 Clear an SV, making it empty. Does not free the memory used by the SV
4296 Perl_sv_clear(pTHX_ register SV *sv)
4300 assert(SvREFCNT(sv) == 0);
4303 if (PL_defstash) { /* Still have a symbol table? */
4308 Zero(&tmpref, 1, SV);
4309 sv_upgrade(&tmpref, SVt_RV);
4311 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4312 SvREFCNT(&tmpref) = 1;
4315 stash = SvSTASH(sv);
4316 destructor = StashHANDLER(stash,DESTROY);
4319 PUSHSTACKi(PERLSI_DESTROY);
4320 SvRV(&tmpref) = SvREFCNT_inc(sv);
4325 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4331 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4333 del_XRV(SvANY(&tmpref));
4336 if (PL_in_clean_objs)
4337 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4339 /* DESTROY gave object new lease on life */
4345 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4346 SvOBJECT_off(sv); /* Curse the object. */
4347 if (SvTYPE(sv) != SVt_PVIO)
4348 --PL_sv_objcount; /* XXX Might want something more general */
4351 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4354 switch (SvTYPE(sv)) {
4357 IoIFP(sv) != PerlIO_stdin() &&
4358 IoIFP(sv) != PerlIO_stdout() &&
4359 IoIFP(sv) != PerlIO_stderr())
4361 io_close((IO*)sv, FALSE);
4363 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4364 PerlDir_close(IoDIRP(sv));
4365 IoDIRP(sv) = (DIR*)NULL;
4366 Safefree(IoTOP_NAME(sv));
4367 Safefree(IoFMT_NAME(sv));
4368 Safefree(IoBOTTOM_NAME(sv));
4383 SvREFCNT_dec(LvTARG(sv));
4387 Safefree(GvNAME(sv));
4388 /* cannot decrease stash refcount yet, as we might recursively delete
4389 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4390 of stash until current sv is completely gone.
4391 -- JohnPC, 27 Mar 1998 */
4392 stash = GvSTASH(sv);
4398 (void)SvOOK_off(sv);
4406 SvREFCNT_dec(SvRV(sv));
4408 else if (SvPVX(sv) && SvLEN(sv))
4409 Safefree(SvPVX(sv));
4410 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4411 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4423 switch (SvTYPE(sv)) {
4439 del_XPVIV(SvANY(sv));
4442 del_XPVNV(SvANY(sv));
4445 del_XPVMG(SvANY(sv));
4448 del_XPVLV(SvANY(sv));
4451 del_XPVAV(SvANY(sv));
4454 del_XPVHV(SvANY(sv));
4457 del_XPVCV(SvANY(sv));
4460 del_XPVGV(SvANY(sv));
4461 /* code duplication for increased performance. */
4462 SvFLAGS(sv) &= SVf_BREAK;
4463 SvFLAGS(sv) |= SVTYPEMASK;
4464 /* decrease refcount of the stash that owns this GV, if any */
4466 SvREFCNT_dec(stash);
4467 return; /* not break, SvFLAGS reset already happened */
4469 del_XPVBM(SvANY(sv));
4472 del_XPVFM(SvANY(sv));
4475 del_XPVIO(SvANY(sv));
4478 SvFLAGS(sv) &= SVf_BREAK;
4479 SvFLAGS(sv) |= SVTYPEMASK;
4483 Perl_sv_newref(pTHX_ SV *sv)
4486 ATOMIC_INC(SvREFCNT(sv));
4493 Free the memory used by an SV.
4499 Perl_sv_free(pTHX_ SV *sv)
4501 int refcount_is_zero;
4505 if (SvREFCNT(sv) == 0) {
4506 if (SvFLAGS(sv) & SVf_BREAK)
4508 if (PL_in_clean_all) /* All is fair */
4510 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4511 /* make sure SvREFCNT(sv)==0 happens very seldom */
4512 SvREFCNT(sv) = (~(U32)0)/2;
4515 if (ckWARN_d(WARN_INTERNAL))
4516 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4519 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4520 if (!refcount_is_zero)
4524 if (ckWARN_d(WARN_DEBUGGING))
4525 Perl_warner(aTHX_ WARN_DEBUGGING,
4526 "Attempt to free temp prematurely: SV 0x%"UVxf,
4531 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4532 /* make sure SvREFCNT(sv)==0 happens very seldom */
4533 SvREFCNT(sv) = (~(U32)0)/2;
4544 Returns the length of the string in the SV. See also C<SvCUR>.
4550 Perl_sv_len(pTHX_ register SV *sv)
4559 len = mg_length(sv);
4561 junk = SvPV(sv, len);
4566 =for apidoc sv_len_utf8
4568 Returns the number of characters in the string in an SV, counting wide
4569 UTF8 bytes as a single character.
4575 Perl_sv_len_utf8(pTHX_ register SV *sv)
4581 return mg_length(sv);
4585 U8 *s = (U8*)SvPV(sv, len);
4587 return Perl_utf8_length(aTHX_ s, s + len);
4592 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4597 I32 uoffset = *offsetp;
4603 start = s = (U8*)SvPV(sv, len);
4605 while (s < send && uoffset--)
4609 *offsetp = s - start;
4613 while (s < send && ulen--)
4623 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4632 s = (U8*)SvPV(sv, len);
4634 Perl_croak(aTHX_ "panic: bad byte offset");
4635 send = s + *offsetp;
4642 if (ckWARN_d(WARN_UTF8))
4643 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4653 Returns a boolean indicating whether the strings in the two SVs are
4660 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4667 bool pv1tmp = FALSE;
4668 bool pv2tmp = FALSE;
4675 pv1 = SvPV(sv1, cur1);
4682 pv2 = SvPV(sv2, cur2);
4684 /* do not utf8ize the comparands as a side-effect */
4685 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4687 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4691 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4697 eq = memEQ(pv1, pv2, cur1);
4710 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4711 string in C<sv1> is less than, equal to, or greater than the string in
4718 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4723 bool pv1tmp = FALSE;
4724 bool pv2tmp = FALSE;
4731 pv1 = SvPV(sv1, cur1);
4738 pv2 = SvPV(sv2, cur2);
4740 /* do not utf8ize the comparands as a side-effect */
4741 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4743 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4747 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4753 cmp = cur2 ? -1 : 0;
4757 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4760 cmp = retval < 0 ? -1 : 1;
4761 } else if (cur1 == cur2) {
4764 cmp = cur1 < cur2 ? -1 : 1;
4777 =for apidoc sv_cmp_locale
4779 Compares the strings in two SVs in a locale-aware manner. See
4786 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4788 #ifdef USE_LOCALE_COLLATE
4794 if (PL_collation_standard)
4798 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4800 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4802 if (!pv1 || !len1) {
4813 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4816 return retval < 0 ? -1 : 1;
4819 * When the result of collation is equality, that doesn't mean
4820 * that there are no differences -- some locales exclude some
4821 * characters from consideration. So to avoid false equalities,
4822 * we use the raw string as a tiebreaker.
4828 #endif /* USE_LOCALE_COLLATE */
4830 return sv_cmp(sv1, sv2);
4833 #ifdef USE_LOCALE_COLLATE
4835 * Any scalar variable may carry an 'o' magic that contains the
4836 * scalar data of the variable transformed to such a format that
4837 * a normal memory comparison can be used to compare the data
4838 * according to the locale settings.
4841 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4845 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4846 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4851 Safefree(mg->mg_ptr);
4853 if ((xf = mem_collxfrm(s, len, &xlen))) {
4854 if (SvREADONLY(sv)) {
4857 return xf + sizeof(PL_collation_ix);
4860 sv_magic(sv, 0, 'o', 0, 0);
4861 mg = mg_find(sv, 'o');
4874 if (mg && mg->mg_ptr) {
4876 return mg->mg_ptr + sizeof(PL_collation_ix);
4884 #endif /* USE_LOCALE_COLLATE */
4889 Get a line from the filehandle and store it into the SV, optionally
4890 appending to the currently-stored string.
4896 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4900 register STDCHAR rslast;
4901 register STDCHAR *bp;
4905 SV_CHECK_THINKFIRST(sv);
4906 (void)SvUPGRADE(sv, SVt_PV);
4910 if (RsSNARF(PL_rs)) {
4914 else if (RsRECORD(PL_rs)) {
4915 I32 recsize, bytesread;
4918 /* Grab the size of the record we're getting */
4919 recsize = SvIV(SvRV(PL_rs));
4920 (void)SvPOK_only(sv); /* Validate pointer */
4921 buffer = SvGROW(sv, recsize + 1);
4924 /* VMS wants read instead of fread, because fread doesn't respect */
4925 /* RMS record boundaries. This is not necessarily a good thing to be */
4926 /* doing, but we've got no other real choice */
4927 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4929 bytesread = PerlIO_read(fp, buffer, recsize);
4931 SvCUR_set(sv, bytesread);
4932 buffer[bytesread] = '\0';
4933 if (PerlIO_isutf8(fp))
4937 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4939 else if (RsPARA(PL_rs)) {
4944 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4945 if (PerlIO_isutf8(fp)) {
4946 rsptr = SvPVutf8(PL_rs, rslen);
4949 if (SvUTF8(PL_rs)) {
4950 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4951 Perl_croak(aTHX_ "Wide character in $/");
4954 rsptr = SvPV(PL_rs, rslen);
4958 rslast = rslen ? rsptr[rslen - 1] : '\0';
4960 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4961 do { /* to make sure file boundaries work right */
4964 i = PerlIO_getc(fp);
4968 PerlIO_ungetc(fp,i);
4974 /* See if we know enough about I/O mechanism to cheat it ! */
4976 /* This used to be #ifdef test - it is made run-time test for ease
4977 of abstracting out stdio interface. One call should be cheap
4978 enough here - and may even be a macro allowing compile
4982 if (PerlIO_fast_gets(fp)) {
4985 * We're going to steal some values from the stdio struct
4986 * and put EVERYTHING in the innermost loop into registers.
4988 register STDCHAR *ptr;
4992 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4993 /* An ungetc()d char is handled separately from the regular
4994 * buffer, so we getc() it back out and stuff it in the buffer.
4996 i = PerlIO_getc(fp);
4997 if (i == EOF) return 0;
4998 *(--((*fp)->_ptr)) = (unsigned char) i;
5002 /* Here is some breathtakingly efficient cheating */
5004 cnt = PerlIO_get_cnt(fp); /* get count into register */
5005 (void)SvPOK_only(sv); /* validate pointer */
5006 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5007 if (cnt > 80 && SvLEN(sv) > append) {
5008 shortbuffered = cnt - SvLEN(sv) + append + 1;
5009 cnt -= shortbuffered;
5013 /* remember that cnt can be negative */
5014 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5019 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5020 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5021 DEBUG_P(PerlIO_printf(Perl_debug_log,
5022 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5023 DEBUG_P(PerlIO_printf(Perl_debug_log,
5024 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5025 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5026 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5031 while (cnt > 0) { /* this | eat */
5033 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5034 goto thats_all_folks; /* screams | sed :-) */
5038 Copy(ptr, bp, cnt, char); /* this | eat */
5039 bp += cnt; /* screams | dust */
5040 ptr += cnt; /* louder | sed :-) */
5045 if (shortbuffered) { /* oh well, must extend */
5046 cnt = shortbuffered;
5048 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5050 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5051 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5055 DEBUG_P(PerlIO_printf(Perl_debug_log,
5056 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5057 PTR2UV(ptr),(long)cnt));
5058 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5059 DEBUG_P(PerlIO_printf(Perl_debug_log,
5060 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5061 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5062 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5063 /* This used to call 'filbuf' in stdio form, but as that behaves like
5064 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5065 another abstraction. */
5066 i = PerlIO_getc(fp); /* get more characters */
5067 DEBUG_P(PerlIO_printf(Perl_debug_log,
5068 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5069 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5070 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5071 cnt = PerlIO_get_cnt(fp);
5072 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5073 DEBUG_P(PerlIO_printf(Perl_debug_log,
5074 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5076 if (i == EOF) /* all done for ever? */
5077 goto thats_really_all_folks;
5079 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5081 SvGROW(sv, bpx + cnt + 2);
5082 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5084 *bp++ = i; /* store character from PerlIO_getc */
5086 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5087 goto thats_all_folks;
5091 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5092 memNE((char*)bp - rslen, rsptr, rslen))
5093 goto screamer; /* go back to the fray */
5094 thats_really_all_folks:
5096 cnt += shortbuffered;
5097 DEBUG_P(PerlIO_printf(Perl_debug_log,
5098 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5099 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5100 DEBUG_P(PerlIO_printf(Perl_debug_log,
5101 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5102 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5103 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5105 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5106 DEBUG_P(PerlIO_printf(Perl_debug_log,
5107 "Screamer: done, len=%ld, string=|%.*s|\n",
5108 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5113 /*The big, slow, and stupid way */
5116 /* Need to work around EPOC SDK features */
5117 /* On WINS: MS VC5 generates calls to _chkstk, */
5118 /* if a `large' stack frame is allocated */
5119 /* gcc on MARM does not generate calls like these */
5125 register STDCHAR *bpe = buf + sizeof(buf);
5127 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5128 ; /* keep reading */
5132 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5133 /* Accomodate broken VAXC compiler, which applies U8 cast to
5134 * both args of ?: operator, causing EOF to change into 255
5136 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5140 sv_catpvn(sv, (char *) buf, cnt);
5142 sv_setpvn(sv, (char *) buf, cnt);
5144 if (i != EOF && /* joy */
5146 SvCUR(sv) < rslen ||
5147 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5151 * If we're reading from a TTY and we get a short read,
5152 * indicating that the user hit his EOF character, we need
5153 * to notice it now, because if we try to read from the TTY
5154 * again, the EOF condition will disappear.
5156 * The comparison of cnt to sizeof(buf) is an optimization
5157 * that prevents unnecessary calls to feof().
5161 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5166 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5167 while (i != EOF) { /* to make sure file boundaries work right */
5168 i = PerlIO_getc(fp);
5170 PerlIO_ungetc(fp,i);
5176 if (PerlIO_isutf8(fp))
5181 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5188 Auto-increment of the value in the SV.
5194 Perl_sv_inc(pTHX_ register SV *sv)
5203 if (SvTHINKFIRST(sv)) {
5204 if (SvREADONLY(sv)) {
5205 if (PL_curcop != &PL_compiling)
5206 Perl_croak(aTHX_ PL_no_modify);
5210 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5212 i = PTR2IV(SvRV(sv));
5217 flags = SvFLAGS(sv);
5218 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5219 /* It's (privately or publicly) a float, but not tested as an
5220 integer, so test it to see. */
5222 flags = SvFLAGS(sv);
5224 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5225 /* It's publicly an integer, or privately an integer-not-float */
5228 if (SvUVX(sv) == UV_MAX)
5229 sv_setnv(sv, (NV)UV_MAX + 1.0);
5231 (void)SvIOK_only_UV(sv);
5234 if (SvIVX(sv) == IV_MAX)
5235 sv_setuv(sv, (UV)IV_MAX + 1);
5237 (void)SvIOK_only(sv);
5243 if (flags & SVp_NOK) {
5244 (void)SvNOK_only(sv);
5249 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5250 if ((flags & SVTYPEMASK) < SVt_PVIV)
5251 sv_upgrade(sv, SVt_IV);
5252 (void)SvIOK_only(sv);
5257 while (isALPHA(*d)) d++;
5258 while (isDIGIT(*d)) d++;
5260 #ifdef PERL_PRESERVE_IVUV
5261 /* Got to punt this an an integer if needs be, but we don't issue
5262 warnings. Probably ought to make the sv_iv_please() that does
5263 the conversion if possible, and silently. */
5264 I32 numtype = looks_like_number(sv);
5265 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5266 /* Need to try really hard to see if it's an integer.
5267 9.22337203685478e+18 is an integer.
5268 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5269 so $a="9.22337203685478e+18"; $a+0; $a++
5270 needs to be the same as $a="9.22337203685478e+18"; $a++
5277 /* sv_2iv *should* have made this an NV */
5278 if (flags & SVp_NOK) {
5279 (void)SvNOK_only(sv);
5283 /* I don't think we can get here. Maybe I should assert this
5284 And if we do get here I suspect that sv_setnv will croak. NWC
5286 #if defined(USE_LONG_DOUBLE)
5287 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",
5288 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5290 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5291 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5294 #endif /* PERL_PRESERVE_IVUV */
5295 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5299 while (d >= SvPVX(sv)) {
5307 /* MKS: The original code here died if letters weren't consecutive.
5308 * at least it didn't have to worry about non-C locales. The
5309 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5310 * arranged in order (although not consecutively) and that only
5311 * [A-Za-z] are accepted by isALPHA in the C locale.
5313 if (*d != 'z' && *d != 'Z') {
5314 do { ++*d; } while (!isALPHA(*d));
5317 *(d--) -= 'z' - 'a';
5322 *(d--) -= 'z' - 'a' + 1;
5326 /* oh,oh, the number grew */
5327 SvGROW(sv, SvCUR(sv) + 2);
5329 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5340 Auto-decrement of the value in the SV.
5346 Perl_sv_dec(pTHX_ register SV *sv)
5354 if (SvTHINKFIRST(sv)) {
5355 if (SvREADONLY(sv)) {
5356 if (PL_curcop != &PL_compiling)
5357 Perl_croak(aTHX_ PL_no_modify);
5361 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5363 i = PTR2IV(SvRV(sv));
5368 /* Unlike sv_inc we don't have to worry about string-never-numbers
5369 and keeping them magic. But we mustn't warn on punting */
5370 flags = SvFLAGS(sv);
5371 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5372 /* It's publicly an integer, or privately an integer-not-float */
5375 if (SvUVX(sv) == 0) {
5376 (void)SvIOK_only(sv);
5380 (void)SvIOK_only_UV(sv);
5384 if (SvIVX(sv) == IV_MIN)
5385 sv_setnv(sv, (NV)IV_MIN - 1.0);
5387 (void)SvIOK_only(sv);
5393 if (flags & SVp_NOK) {
5395 (void)SvNOK_only(sv);
5398 if (!(flags & SVp_POK)) {
5399 if ((flags & SVTYPEMASK) < SVt_PVNV)
5400 sv_upgrade(sv, SVt_NV);
5402 (void)SvNOK_only(sv);
5405 #ifdef PERL_PRESERVE_IVUV
5407 I32 numtype = looks_like_number(sv);
5408 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5409 /* Need to try really hard to see if it's an integer.
5410 9.22337203685478e+18 is an integer.
5411 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5412 so $a="9.22337203685478e+18"; $a+0; $a--
5413 needs to be the same as $a="9.22337203685478e+18"; $a--
5420 /* sv_2iv *should* have made this an NV */
5421 if (flags & SVp_NOK) {
5422 (void)SvNOK_only(sv);
5426 /* I don't think we can get here. Maybe I should assert this
5427 And if we do get here I suspect that sv_setnv will croak. NWC
5429 #if defined(USE_LONG_DOUBLE)
5430 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",
5431 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5433 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5434 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5438 #endif /* PERL_PRESERVE_IVUV */
5439 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5443 =for apidoc sv_mortalcopy
5445 Creates a new SV which is a copy of the original SV. The new SV is marked
5451 /* Make a string that will exist for the duration of the expression
5452 * evaluation. Actually, it may have to last longer than that, but
5453 * hopefully we won't free it until it has been assigned to a
5454 * permanent location. */
5457 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5462 sv_setsv(sv,oldstr);
5464 PL_tmps_stack[++PL_tmps_ix] = sv;
5470 =for apidoc sv_newmortal
5472 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5478 Perl_sv_newmortal(pTHX)
5483 SvFLAGS(sv) = SVs_TEMP;
5485 PL_tmps_stack[++PL_tmps_ix] = sv;
5490 =for apidoc sv_2mortal
5492 Marks an SV as mortal. The SV will be destroyed when the current context
5498 /* same thing without the copying */
5501 Perl_sv_2mortal(pTHX_ register SV *sv)
5505 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5508 PL_tmps_stack[++PL_tmps_ix] = sv;
5516 Creates a new SV and copies a string into it. The reference count for the
5517 SV is set to 1. If C<len> is zero, Perl will compute the length using
5518 strlen(). For efficiency, consider using C<newSVpvn> instead.
5524 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5531 sv_setpvn(sv,s,len);
5536 =for apidoc newSVpvn
5538 Creates a new SV and copies a string into it. The reference count for the
5539 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5540 string. You are responsible for ensuring that the source string is at least
5547 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5552 sv_setpvn(sv,s,len);
5557 =for apidoc newSVpvn_share
5559 Creates a new SV and populates it with a string from
5560 the string table. Turns on READONLY and FAKE.
5561 The idea here is that as string table is used for shared hash
5562 keys these strings will have SvPVX == HeKEY and hash lookup
5563 will avoid string compare.
5569 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5572 bool is_utf8 = FALSE;
5578 PERL_HASH(hash, src, len);
5580 sv_upgrade(sv, SVt_PVIV);
5581 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5593 #if defined(PERL_IMPLICIT_CONTEXT)
5595 Perl_newSVpvf_nocontext(const char* pat, ...)
5600 va_start(args, pat);
5601 sv = vnewSVpvf(pat, &args);
5608 =for apidoc newSVpvf
5610 Creates a new SV an initialize it with the string formatted like
5617 Perl_newSVpvf(pTHX_ const char* pat, ...)
5621 va_start(args, pat);
5622 sv = vnewSVpvf(pat, &args);
5628 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5632 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5639 Creates a new SV and copies a floating point value into it.
5640 The reference count for the SV is set to 1.
5646 Perl_newSVnv(pTHX_ NV n)
5658 Creates a new SV and copies an integer into it. The reference count for the
5665 Perl_newSViv(pTHX_ IV i)
5677 Creates a new SV and copies an unsigned integer into it.
5678 The reference count for the SV is set to 1.
5684 Perl_newSVuv(pTHX_ UV u)
5694 =for apidoc newRV_noinc
5696 Creates an RV wrapper for an SV. The reference count for the original
5697 SV is B<not> incremented.
5703 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5708 sv_upgrade(sv, SVt_RV);
5715 /* newRV_inc is #defined to newRV in sv.h */
5717 Perl_newRV(pTHX_ SV *tmpRef)
5719 return newRV_noinc(SvREFCNT_inc(tmpRef));
5725 Creates a new SV which is an exact duplicate of the original SV.
5730 /* make an exact duplicate of old */
5733 Perl_newSVsv(pTHX_ register SV *old)
5739 if (SvTYPE(old) == SVTYPEMASK) {
5740 if (ckWARN_d(WARN_INTERNAL))
5741 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5756 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5764 char todo[PERL_UCHAR_MAX+1];
5769 if (!*s) { /* reset ?? searches */
5770 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5771 pm->op_pmdynflags &= ~PMdf_USED;
5776 /* reset variables */
5778 if (!HvARRAY(stash))
5781 Zero(todo, 256, char);
5783 i = (unsigned char)*s;
5787 max = (unsigned char)*s++;
5788 for ( ; i <= max; i++) {
5791 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5792 for (entry = HvARRAY(stash)[i];
5794 entry = HeNEXT(entry))
5796 if (!todo[(U8)*HeKEY(entry)])
5798 gv = (GV*)HeVAL(entry);
5800 if (SvTHINKFIRST(sv)) {
5801 if (!SvREADONLY(sv) && SvROK(sv))
5806 if (SvTYPE(sv) >= SVt_PV) {
5808 if (SvPVX(sv) != Nullch)
5815 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5817 #ifdef USE_ENVIRON_ARRAY
5819 environ[0] = Nullch;
5828 Perl_sv_2io(pTHX_ SV *sv)
5834 switch (SvTYPE(sv)) {
5842 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5846 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5848 return sv_2io(SvRV(sv));
5849 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5855 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5862 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5869 return *gvp = Nullgv, Nullcv;
5870 switch (SvTYPE(sv)) {
5889 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5890 tryAMAGICunDEREF(to_cv);
5893 if (SvTYPE(sv) == SVt_PVCV) {
5902 Perl_croak(aTHX_ "Not a subroutine reference");
5907 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5913 if (lref && !GvCVu(gv)) {
5916 tmpsv = NEWSV(704,0);
5917 gv_efullname3(tmpsv, gv, Nullch);
5918 /* XXX this is probably not what they think they're getting.
5919 * It has the same effect as "sub name;", i.e. just a forward
5921 newSUB(start_subparse(FALSE, 0),
5922 newSVOP(OP_CONST, 0, tmpsv),
5927 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5936 Returns true if the SV has a true value by Perl's rules.
5942 Perl_sv_true(pTHX_ register SV *sv)
5948 if ((tXpv = (XPV*)SvANY(sv)) &&
5949 (tXpv->xpv_cur > 1 ||
5950 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5957 return SvIVX(sv) != 0;
5960 return SvNVX(sv) != 0.0;
5962 return sv_2bool(sv);
5968 Perl_sv_iv(pTHX_ register SV *sv)
5972 return (IV)SvUVX(sv);
5979 Perl_sv_uv(pTHX_ register SV *sv)
5984 return (UV)SvIVX(sv);
5990 Perl_sv_nv(pTHX_ register SV *sv)
5998 Perl_sv_pv(pTHX_ SV *sv)
6005 return sv_2pv(sv, &n_a);
6009 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6015 return sv_2pv(sv, lp);
6019 =for apidoc sv_pvn_force
6021 Get a sensible string out of the SV somehow.
6027 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6031 if (SvTHINKFIRST(sv) && !SvROK(sv))
6032 sv_force_normal(sv);
6038 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6039 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6040 PL_op_name[PL_op->op_type]);
6044 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6049 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6050 SvGROW(sv, len + 1);
6051 Move(s,SvPVX(sv),len,char);
6056 SvPOK_on(sv); /* validate pointer */
6058 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6059 PTR2UV(sv),SvPVX(sv)));
6066 Perl_sv_pvbyte(pTHX_ SV *sv)
6072 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6074 return sv_pvn(sv,lp);
6078 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6080 return sv_pvn_force(sv,lp);
6084 Perl_sv_pvutf8(pTHX_ SV *sv)
6086 sv_utf8_upgrade(sv);
6091 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6093 sv_utf8_upgrade(sv);
6094 return sv_pvn(sv,lp);
6098 =for apidoc sv_pvutf8n_force
6100 Get a sensible UTF8-encoded string out of the SV somehow. See
6107 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6109 sv_utf8_upgrade(sv);
6110 return sv_pvn_force(sv,lp);
6114 =for apidoc sv_reftype
6116 Returns a string describing what the SV is a reference to.
6122 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6124 if (ob && SvOBJECT(sv))
6125 return HvNAME(SvSTASH(sv));
6127 switch (SvTYPE(sv)) {
6141 case SVt_PVLV: return "LVALUE";
6142 case SVt_PVAV: return "ARRAY";
6143 case SVt_PVHV: return "HASH";
6144 case SVt_PVCV: return "CODE";
6145 case SVt_PVGV: return "GLOB";
6146 case SVt_PVFM: return "FORMAT";
6147 case SVt_PVIO: return "IO";
6148 default: return "UNKNOWN";
6154 =for apidoc sv_isobject
6156 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6157 object. If the SV is not an RV, or if the object is not blessed, then this
6164 Perl_sv_isobject(pTHX_ SV *sv)
6181 Returns a boolean indicating whether the SV is blessed into the specified
6182 class. This does not check for subtypes; use C<sv_derived_from> to verify
6183 an inheritance relationship.
6189 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6201 return strEQ(HvNAME(SvSTASH(sv)), name);
6207 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6208 it will be upgraded to one. If C<classname> is non-null then the new SV will
6209 be blessed in the specified package. The new SV is returned and its
6210 reference count is 1.
6216 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6222 SV_CHECK_THINKFIRST(rv);
6225 if (SvTYPE(rv) >= SVt_PVMG) {
6226 U32 refcnt = SvREFCNT(rv);
6230 SvREFCNT(rv) = refcnt;
6233 if (SvTYPE(rv) < SVt_RV)
6234 sv_upgrade(rv, SVt_RV);
6235 else if (SvTYPE(rv) > SVt_RV) {
6236 (void)SvOOK_off(rv);
6237 if (SvPVX(rv) && SvLEN(rv))
6238 Safefree(SvPVX(rv));
6248 HV* stash = gv_stashpv(classname, TRUE);
6249 (void)sv_bless(rv, stash);
6255 =for apidoc sv_setref_pv
6257 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6258 argument will be upgraded to an RV. That RV will be modified to point to
6259 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6260 into the SV. The C<classname> argument indicates the package for the
6261 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6262 will be returned and will have a reference count of 1.
6264 Do not use with other Perl types such as HV, AV, SV, CV, because those
6265 objects will become corrupted by the pointer copy process.
6267 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6273 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6276 sv_setsv(rv, &PL_sv_undef);
6280 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6285 =for apidoc sv_setref_iv
6287 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6288 argument will be upgraded to an RV. That RV will be modified to point to
6289 the new SV. The C<classname> argument indicates the package for the
6290 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6291 will be returned and will have a reference count of 1.
6297 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6299 sv_setiv(newSVrv(rv,classname), iv);
6304 =for apidoc sv_setref_nv
6306 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6307 argument will be upgraded to an RV. That RV will be modified to point to
6308 the new SV. The C<classname> argument indicates the package for the
6309 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6310 will be returned and will have a reference count of 1.
6316 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6318 sv_setnv(newSVrv(rv,classname), nv);
6323 =for apidoc sv_setref_pvn
6325 Copies a string into a new SV, optionally blessing the SV. The length of the
6326 string must be specified with C<n>. The C<rv> argument will be upgraded to
6327 an RV. That RV will be modified to point to the new SV. The C<classname>
6328 argument indicates the package for the blessing. Set C<classname> to
6329 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6330 a reference count of 1.
6332 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6338 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6340 sv_setpvn(newSVrv(rv,classname), pv, n);
6345 =for apidoc sv_bless
6347 Blesses an SV into a specified package. The SV must be an RV. The package
6348 must be designated by its stash (see C<gv_stashpv()>). The reference count
6349 of the SV is unaffected.
6355 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6359 Perl_croak(aTHX_ "Can't bless non-reference value");
6361 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6362 if (SvREADONLY(tmpRef))
6363 Perl_croak(aTHX_ PL_no_modify);
6364 if (SvOBJECT(tmpRef)) {
6365 if (SvTYPE(tmpRef) != SVt_PVIO)
6367 SvREFCNT_dec(SvSTASH(tmpRef));
6370 SvOBJECT_on(tmpRef);
6371 if (SvTYPE(tmpRef) != SVt_PVIO)
6373 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6374 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6385 S_sv_unglob(pTHX_ SV *sv)
6389 assert(SvTYPE(sv) == SVt_PVGV);
6394 SvREFCNT_dec(GvSTASH(sv));
6395 GvSTASH(sv) = Nullhv;
6397 sv_unmagic(sv, '*');
6398 Safefree(GvNAME(sv));
6401 /* need to keep SvANY(sv) in the right arena */
6402 xpvmg = new_XPVMG();
6403 StructCopy(SvANY(sv), xpvmg, XPVMG);
6404 del_XPVGV(SvANY(sv));
6407 SvFLAGS(sv) &= ~SVTYPEMASK;
6408 SvFLAGS(sv) |= SVt_PVMG;
6412 =for apidoc sv_unref_flags
6414 Unsets the RV status of the SV, and decrements the reference count of
6415 whatever was being referenced by the RV. This can almost be thought of
6416 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6417 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6418 (otherwise the decrementing is conditional on the reference count being
6419 different from one or the reference being a readonly SV).
6426 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6430 if (SvWEAKREF(sv)) {
6438 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6440 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6441 sv_2mortal(rv); /* Schedule for freeing later */
6445 =for apidoc sv_unref
6447 Unsets the RV status of the SV, and decrements the reference count of
6448 whatever was being referenced by the RV. This can almost be thought of
6449 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6450 being zero. See C<SvROK_off>.
6456 Perl_sv_unref(pTHX_ SV *sv)
6458 sv_unref_flags(sv, 0);
6462 Perl_sv_taint(pTHX_ SV *sv)
6464 sv_magic((sv), Nullsv, 't', Nullch, 0);
6468 Perl_sv_untaint(pTHX_ SV *sv)
6470 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6471 MAGIC *mg = mg_find(sv, 't');
6478 Perl_sv_tainted(pTHX_ SV *sv)
6480 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6481 MAGIC *mg = mg_find(sv, 't');
6482 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6489 =for apidoc sv_setpviv
6491 Copies an integer into the given SV, also updating its string value.
6492 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6498 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6500 char buf[TYPE_CHARS(UV)];
6502 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6504 sv_setpvn(sv, ptr, ebuf - ptr);
6509 =for apidoc sv_setpviv_mg
6511 Like C<sv_setpviv>, but also handles 'set' magic.
6517 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6519 char buf[TYPE_CHARS(UV)];
6521 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6523 sv_setpvn(sv, ptr, ebuf - ptr);
6527 #if defined(PERL_IMPLICIT_CONTEXT)
6529 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6533 va_start(args, pat);
6534 sv_vsetpvf(sv, pat, &args);
6540 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6544 va_start(args, pat);
6545 sv_vsetpvf_mg(sv, pat, &args);
6551 =for apidoc sv_setpvf
6553 Processes its arguments like C<sprintf> and sets an SV to the formatted
6554 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6560 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6563 va_start(args, pat);
6564 sv_vsetpvf(sv, pat, &args);
6569 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6571 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6575 =for apidoc sv_setpvf_mg
6577 Like C<sv_setpvf>, but also handles 'set' magic.
6583 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6586 va_start(args, pat);
6587 sv_vsetpvf_mg(sv, pat, &args);
6592 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6594 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6598 #if defined(PERL_IMPLICIT_CONTEXT)
6600 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6604 va_start(args, pat);
6605 sv_vcatpvf(sv, pat, &args);
6610 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6614 va_start(args, pat);
6615 sv_vcatpvf_mg(sv, pat, &args);
6621 =for apidoc sv_catpvf
6623 Processes its arguments like C<sprintf> and appends the formatted output
6624 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6625 typically be called after calling this function to handle 'set' magic.
6631 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6634 va_start(args, pat);
6635 sv_vcatpvf(sv, pat, &args);
6640 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6642 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6646 =for apidoc sv_catpvf_mg
6648 Like C<sv_catpvf>, but also handles 'set' magic.
6654 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6657 va_start(args, pat);
6658 sv_vcatpvf_mg(sv, pat, &args);
6663 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6665 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6670 =for apidoc sv_vsetpvfn
6672 Works like C<vcatpvfn> but copies the text into the SV instead of
6679 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6681 sv_setpvn(sv, "", 0);
6682 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6686 =for apidoc sv_vcatpvfn
6688 Processes its arguments like C<vsprintf> and appends the formatted output
6689 to an SV. Uses an array of SVs if the C style variable argument list is
6690 missing (NULL). When running with taint checks enabled, indicates via
6691 C<maybe_tainted> if results are untrustworthy (often due to the use of
6698 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6705 static char nullstr[] = "(null)";
6708 /* no matter what, this is a string now */
6709 (void)SvPV_force(sv, origlen);
6711 /* special-case "", "%s", and "%_" */
6714 if (patlen == 2 && pat[0] == '%') {
6718 char *s = va_arg(*args, char*);
6719 sv_catpv(sv, s ? s : nullstr);
6721 else if (svix < svmax) {
6722 sv_catsv(sv, *svargs);
6723 if (DO_UTF8(*svargs))
6729 argsv = va_arg(*args, SV*);
6730 sv_catsv(sv, argsv);
6735 /* See comment on '_' below */
6740 patend = (char*)pat + patlen;
6741 for (p = (char*)pat; p < patend; p = q) {
6744 bool vectorize = FALSE;
6751 bool has_precis = FALSE;
6753 bool is_utf = FALSE;
6756 U8 utf8buf[UTF8_MAXLEN+1];
6757 STRLEN esignlen = 0;
6759 char *eptr = Nullch;
6761 /* Times 4: a decimal digit takes more than 3 binary digits.
6762 * NV_DIG: mantissa takes than many decimal digits.
6763 * Plus 32: Playing safe. */
6764 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6765 /* large enough for "%#.#f" --chip */
6766 /* what about long double NVs? --jhi */
6769 U8 *vecstr = Null(U8*);
6781 STRLEN dotstrlen = 1;
6782 I32 epix = 0; /* explicit parameter index */
6783 I32 ewix = 0; /* explicit width index */
6784 bool asterisk = FALSE;
6786 for (q = p; q < patend && *q != '%'; ++q) ;
6788 sv_catpvn(sv, p, q - p);
6817 case '*': /* printf("%*vX",":",$ipv6addr) */
6822 vecsv = va_arg(*args, SV*);
6823 else if (svix < svmax)
6824 vecsv = svargs[svix++];
6827 dotstr = SvPVx(vecsv,dotstrlen);
6855 case '1': case '2': case '3':
6856 case '4': case '5': case '6':
6857 case '7': case '8': case '9':
6860 width = width * 10 + (*q++ - '0');
6862 if (asterisk && ewix == 0) {
6867 } else if (epix == 0) {
6879 i = va_arg(*args, int);
6881 i = (ewix ? ewix <= svmax : svix < svmax) ?
6882 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6884 width = (i < 0) ? -i : i;
6893 i = va_arg(*args, int);
6895 i = (ewix ? ewix <= svmax : svix < svmax)
6896 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6897 precis = (i < 0) ? 0 : i;
6903 precis = precis * 10 + (*q++ - '0');
6910 vecsv = va_arg(*args, SV*);
6911 vecstr = (U8*)SvPVx(vecsv,veclen);
6912 utf = DO_UTF8(vecsv);
6914 else if (epix ? epix <= svmax : svix < svmax) {
6915 vecsv = svargs[epix ? epix-1 : svix++];
6916 vecstr = (U8*)SvPVx(vecsv,veclen);
6917 utf = DO_UTF8(vecsv);
6928 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6939 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6940 if (*(q + 1) == 'l') { /* lld, llf */
6967 uv = va_arg(*args, int);
6969 uv = (epix ? epix <= svmax : svix < svmax) ?
6970 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6971 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6972 eptr = (char*)utf8buf;
6973 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6985 eptr = va_arg(*args, char*);
6987 #ifdef MACOS_TRADITIONAL
6988 /* On MacOS, %#s format is used for Pascal strings */
6993 elen = strlen(eptr);
6996 elen = sizeof nullstr - 1;
6999 else if (epix ? epix <= svmax : svix < svmax) {
7000 argsv = svargs[epix ? epix-1 : svix++];
7001 eptr = SvPVx(argsv, elen);
7002 if (DO_UTF8(argsv)) {
7003 if (has_precis && precis < elen) {
7005 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7008 if (width) { /* fudge width (can't fudge elen) */
7009 width += elen - sv_len_utf8(argsv);
7018 * The "%_" hack might have to be changed someday,
7019 * if ISO or ANSI decide to use '_' for something.
7020 * So we keep it hidden from users' code.
7024 argsv = va_arg(*args,SV*);
7025 eptr = SvPVx(argsv, elen);
7031 if (has_precis && elen > precis)
7041 uv = PTR2UV(va_arg(*args, void*));
7043 uv = (epix ? epix <= svmax : svix < svmax) ?
7044 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
7064 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7074 case 'h': iv = (short)va_arg(*args, int); break;
7075 default: iv = va_arg(*args, int); break;
7076 case 'l': iv = va_arg(*args, long); break;
7077 case 'V': iv = va_arg(*args, IV); break;
7079 case 'q': iv = va_arg(*args, Quad_t); break;
7084 iv = (epix ? epix <= svmax : svix < svmax) ?
7085 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
7087 case 'h': iv = (short)iv; break;
7089 case 'l': iv = (long)iv; break;
7092 case 'q': iv = (Quad_t)iv; break;
7099 esignbuf[esignlen++] = plus;
7103 esignbuf[esignlen++] = '-';
7147 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7157 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7158 default: uv = va_arg(*args, unsigned); break;
7159 case 'l': uv = va_arg(*args, unsigned long); break;
7160 case 'V': uv = va_arg(*args, UV); break;
7162 case 'q': uv = va_arg(*args, Quad_t); break;
7167 uv = (epix ? epix <= svmax : svix < svmax) ?
7168 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
7170 case 'h': uv = (unsigned short)uv; break;
7172 case 'l': uv = (unsigned long)uv; break;
7175 case 'q': uv = (Quad_t)uv; break;
7181 eptr = ebuf + sizeof ebuf;
7187 p = (char*)((c == 'X')
7188 ? "0123456789ABCDEF" : "0123456789abcdef");
7194 esignbuf[esignlen++] = '0';
7195 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7201 *--eptr = '0' + dig;
7203 if (alt && *eptr != '0')
7209 *--eptr = '0' + dig;
7212 esignbuf[esignlen++] = '0';
7213 esignbuf[esignlen++] = 'b';
7216 default: /* it had better be ten or less */
7217 #if defined(PERL_Y2KWARN)
7218 if (ckWARN(WARN_Y2K)) {
7220 char *s = SvPV(sv,n);
7221 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7222 && (n == 2 || !isDIGIT(s[n-3])))
7224 Perl_warner(aTHX_ WARN_Y2K,
7225 "Possible Y2K bug: %%%c %s",
7226 c, "format string following '19'");
7232 *--eptr = '0' + dig;
7233 } while (uv /= base);
7236 elen = (ebuf + sizeof ebuf) - eptr;
7239 zeros = precis - elen;
7240 else if (precis == 0 && elen == 1 && *eptr == '0')
7245 /* FLOATING POINT */
7248 c = 'f'; /* maybe %F isn't supported here */
7254 /* This is evil, but floating point is even more evil */
7258 nv = va_arg(*args, NV);
7260 nv = (epix ? epix <= svmax : svix < svmax) ?
7261 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
7264 if (c != 'e' && c != 'E') {
7266 (void)Perl_frexp(nv, &i);
7267 if (i == PERL_INT_MIN)
7268 Perl_die(aTHX_ "panic: frexp");
7270 need = BIT_DIGITS(i);
7272 need += has_precis ? precis : 6; /* known default */
7276 need += 20; /* fudge factor */
7277 if (PL_efloatsize < need) {
7278 Safefree(PL_efloatbuf);
7279 PL_efloatsize = need + 20; /* more fudge */
7280 New(906, PL_efloatbuf, PL_efloatsize, char);
7281 PL_efloatbuf[0] = '\0';
7284 eptr = ebuf + sizeof ebuf;
7287 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7289 /* Copy the one or more characters in a long double
7290 * format before the 'base' ([efgEFG]) character to
7291 * the format string. */
7292 static char const prifldbl[] = PERL_PRIfldbl;
7293 char const *p = prifldbl + sizeof(prifldbl) - 3;
7294 while (p >= prifldbl) { *--eptr = *p--; }
7299 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7304 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7316 /* No taint. Otherwise we are in the strange situation
7317 * where printf() taints but print($float) doesn't.
7319 (void)sprintf(PL_efloatbuf, eptr, nv);
7321 eptr = PL_efloatbuf;
7322 elen = strlen(PL_efloatbuf);
7329 i = SvCUR(sv) - origlen;
7332 case 'h': *(va_arg(*args, short*)) = i; break;
7333 default: *(va_arg(*args, int*)) = i; break;
7334 case 'l': *(va_arg(*args, long*)) = i; break;
7335 case 'V': *(va_arg(*args, IV*)) = i; break;
7337 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7341 else if (epix ? epix <= svmax : svix < svmax)
7342 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
7343 continue; /* not "break" */
7350 if (!args && ckWARN(WARN_PRINTF) &&
7351 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7352 SV *msg = sv_newmortal();
7353 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7354 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7357 Perl_sv_catpvf(aTHX_ msg,
7358 "\"%%%c\"", c & 0xFF);
7360 Perl_sv_catpvf(aTHX_ msg,
7361 "\"%%\\%03"UVof"\"",
7364 sv_catpv(msg, "end of string");
7365 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7368 /* output mangled stuff ... */
7374 /* ... right here, because formatting flags should not apply */
7375 SvGROW(sv, SvCUR(sv) + elen + 1);
7377 memcpy(p, eptr, elen);
7380 SvCUR(sv) = p - SvPVX(sv);
7381 continue; /* not "break" */
7384 have = esignlen + zeros + elen;
7385 need = (have > width ? have : width);
7388 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7390 if (esignlen && fill == '0') {
7391 for (i = 0; i < esignlen; i++)
7395 memset(p, fill, gap);
7398 if (esignlen && fill != '0') {
7399 for (i = 0; i < esignlen; i++)
7403 for (i = zeros; i; i--)
7407 memcpy(p, eptr, elen);
7411 memset(p, ' ', gap);
7416 memcpy(p, dotstr, dotstrlen);
7420 vectorize = FALSE; /* done iterating over vecstr */
7425 SvCUR(sv) = p - SvPVX(sv);
7433 #if defined(USE_ITHREADS)
7435 #if defined(USE_THREADS)
7436 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7439 #ifndef GpREFCNT_inc
7440 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7444 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7445 #define av_dup(s) (AV*)sv_dup((SV*)s)
7446 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7447 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7448 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7449 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7450 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7451 #define io_dup(s) (IO*)sv_dup((SV*)s)
7452 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7453 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7454 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7455 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7456 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7459 Perl_re_dup(pTHX_ REGEXP *r)
7461 /* XXX fix when pmop->op_pmregexp becomes shared */
7462 return ReREFCNT_inc(r);
7466 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7470 return (PerlIO*)NULL;
7472 /* look for it in the table first */
7473 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7477 /* create anew and remember what it is */
7478 ret = PerlIO_fdupopen(aTHX_ fp);
7479 ptr_table_store(PL_ptr_table, fp, ret);
7484 Perl_dirp_dup(pTHX_ DIR *dp)
7493 Perl_gp_dup(pTHX_ GP *gp)
7498 /* look for it in the table first */
7499 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7503 /* create anew and remember what it is */
7504 Newz(0, ret, 1, GP);
7505 ptr_table_store(PL_ptr_table, gp, ret);
7508 ret->gp_refcnt = 0; /* must be before any other dups! */
7509 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7510 ret->gp_io = io_dup_inc(gp->gp_io);
7511 ret->gp_form = cv_dup_inc(gp->gp_form);
7512 ret->gp_av = av_dup_inc(gp->gp_av);
7513 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7514 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7515 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7516 ret->gp_cvgen = gp->gp_cvgen;
7517 ret->gp_flags = gp->gp_flags;
7518 ret->gp_line = gp->gp_line;
7519 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7524 Perl_mg_dup(pTHX_ MAGIC *mg)
7526 MAGIC *mgret = (MAGIC*)NULL;
7529 return (MAGIC*)NULL;
7530 /* look for it in the table first */
7531 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7535 for (; mg; mg = mg->mg_moremagic) {
7537 Newz(0, nmg, 1, MAGIC);
7541 mgprev->mg_moremagic = nmg;
7542 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7543 nmg->mg_private = mg->mg_private;
7544 nmg->mg_type = mg->mg_type;
7545 nmg->mg_flags = mg->mg_flags;
7546 if (mg->mg_type == 'r') {
7547 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7550 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7551 ? sv_dup_inc(mg->mg_obj)
7552 : sv_dup(mg->mg_obj);
7554 nmg->mg_len = mg->mg_len;
7555 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7556 if (mg->mg_ptr && mg->mg_type != 'g') {
7557 if (mg->mg_len >= 0) {
7558 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7559 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7560 AMT *amtp = (AMT*)mg->mg_ptr;
7561 AMT *namtp = (AMT*)nmg->mg_ptr;
7563 for (i = 1; i < NofAMmeth; i++) {
7564 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7568 else if (mg->mg_len == HEf_SVKEY)
7569 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7577 Perl_ptr_table_new(pTHX)
7580 Newz(0, tbl, 1, PTR_TBL_t);
7583 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7588 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7590 PTR_TBL_ENT_t *tblent;
7591 UV hash = PTR2UV(sv);
7593 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7594 for (; tblent; tblent = tblent->next) {
7595 if (tblent->oldval == sv)
7596 return tblent->newval;
7602 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7604 PTR_TBL_ENT_t *tblent, **otblent;
7605 /* XXX this may be pessimal on platforms where pointers aren't good
7606 * hash values e.g. if they grow faster in the most significant
7608 UV hash = PTR2UV(oldv);
7612 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7613 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7614 if (tblent->oldval == oldv) {
7615 tblent->newval = newv;
7620 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7621 tblent->oldval = oldv;
7622 tblent->newval = newv;
7623 tblent->next = *otblent;
7626 if (i && tbl->tbl_items > tbl->tbl_max)
7627 ptr_table_split(tbl);
7631 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7633 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7634 UV oldsize = tbl->tbl_max + 1;
7635 UV newsize = oldsize * 2;
7638 Renew(ary, newsize, PTR_TBL_ENT_t*);
7639 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7640 tbl->tbl_max = --newsize;
7642 for (i=0; i < oldsize; i++, ary++) {
7643 PTR_TBL_ENT_t **curentp, **entp, *ent;
7646 curentp = ary + oldsize;
7647 for (entp = ary, ent = *ary; ent; ent = *entp) {
7648 if ((newsize & PTR2UV(ent->oldval)) != i) {
7650 ent->next = *curentp;
7665 Perl_sv_dup(pTHX_ SV *sstr)
7669 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7671 /* look for it in the table first */
7672 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7676 /* create anew and remember what it is */
7678 ptr_table_store(PL_ptr_table, sstr, dstr);
7681 SvFLAGS(dstr) = SvFLAGS(sstr);
7682 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7683 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7686 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7687 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7688 PL_watch_pvx, SvPVX(sstr));
7691 switch (SvTYPE(sstr)) {
7696 SvANY(dstr) = new_XIV();
7697 SvIVX(dstr) = SvIVX(sstr);
7700 SvANY(dstr) = new_XNV();
7701 SvNVX(dstr) = SvNVX(sstr);
7704 SvANY(dstr) = new_XRV();
7705 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7708 SvANY(dstr) = new_XPV();
7709 SvCUR(dstr) = SvCUR(sstr);
7710 SvLEN(dstr) = SvLEN(sstr);
7712 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7713 else if (SvPVX(sstr) && SvLEN(sstr))
7714 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7716 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7719 SvANY(dstr) = new_XPVIV();
7720 SvCUR(dstr) = SvCUR(sstr);
7721 SvLEN(dstr) = SvLEN(sstr);
7722 SvIVX(dstr) = SvIVX(sstr);
7724 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7725 else if (SvPVX(sstr) && SvLEN(sstr))
7726 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7728 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7731 SvANY(dstr) = new_XPVNV();
7732 SvCUR(dstr) = SvCUR(sstr);
7733 SvLEN(dstr) = SvLEN(sstr);
7734 SvIVX(dstr) = SvIVX(sstr);
7735 SvNVX(dstr) = SvNVX(sstr);
7737 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7738 else if (SvPVX(sstr) && SvLEN(sstr))
7739 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7741 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7744 SvANY(dstr) = new_XPVMG();
7745 SvCUR(dstr) = SvCUR(sstr);
7746 SvLEN(dstr) = SvLEN(sstr);
7747 SvIVX(dstr) = SvIVX(sstr);
7748 SvNVX(dstr) = SvNVX(sstr);
7749 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7750 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7752 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7753 else if (SvPVX(sstr) && SvLEN(sstr))
7754 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7756 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7759 SvANY(dstr) = new_XPVBM();
7760 SvCUR(dstr) = SvCUR(sstr);
7761 SvLEN(dstr) = SvLEN(sstr);
7762 SvIVX(dstr) = SvIVX(sstr);
7763 SvNVX(dstr) = SvNVX(sstr);
7764 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7765 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7767 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7768 else if (SvPVX(sstr) && SvLEN(sstr))
7769 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7771 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7772 BmRARE(dstr) = BmRARE(sstr);
7773 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7774 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7777 SvANY(dstr) = new_XPVLV();
7778 SvCUR(dstr) = SvCUR(sstr);
7779 SvLEN(dstr) = SvLEN(sstr);
7780 SvIVX(dstr) = SvIVX(sstr);
7781 SvNVX(dstr) = SvNVX(sstr);
7782 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7783 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7785 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7786 else if (SvPVX(sstr) && SvLEN(sstr))
7787 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7789 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7790 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7791 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7792 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7793 LvTYPE(dstr) = LvTYPE(sstr);
7796 SvANY(dstr) = new_XPVGV();
7797 SvCUR(dstr) = SvCUR(sstr);
7798 SvLEN(dstr) = SvLEN(sstr);
7799 SvIVX(dstr) = SvIVX(sstr);
7800 SvNVX(dstr) = SvNVX(sstr);
7801 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7802 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7804 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7805 else if (SvPVX(sstr) && SvLEN(sstr))
7806 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7808 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7809 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7810 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7811 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7812 GvFLAGS(dstr) = GvFLAGS(sstr);
7813 GvGP(dstr) = gp_dup(GvGP(sstr));
7814 (void)GpREFCNT_inc(GvGP(dstr));
7817 SvANY(dstr) = new_XPVIO();
7818 SvCUR(dstr) = SvCUR(sstr);
7819 SvLEN(dstr) = SvLEN(sstr);
7820 SvIVX(dstr) = SvIVX(sstr);
7821 SvNVX(dstr) = SvNVX(sstr);
7822 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7823 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7825 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7826 else if (SvPVX(sstr) && SvLEN(sstr))
7827 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7829 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7830 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7831 if (IoOFP(sstr) == IoIFP(sstr))
7832 IoOFP(dstr) = IoIFP(dstr);
7834 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7835 /* PL_rsfp_filters entries have fake IoDIRP() */
7836 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7837 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7839 IoDIRP(dstr) = IoDIRP(sstr);
7840 IoLINES(dstr) = IoLINES(sstr);
7841 IoPAGE(dstr) = IoPAGE(sstr);
7842 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7843 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7844 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7845 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7846 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7847 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7848 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7849 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7850 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7851 IoTYPE(dstr) = IoTYPE(sstr);
7852 IoFLAGS(dstr) = IoFLAGS(sstr);
7855 SvANY(dstr) = new_XPVAV();
7856 SvCUR(dstr) = SvCUR(sstr);
7857 SvLEN(dstr) = SvLEN(sstr);
7858 SvIVX(dstr) = SvIVX(sstr);
7859 SvNVX(dstr) = SvNVX(sstr);
7860 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7861 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7862 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7863 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7864 if (AvARRAY((AV*)sstr)) {
7865 SV **dst_ary, **src_ary;
7866 SSize_t items = AvFILLp((AV*)sstr) + 1;
7868 src_ary = AvARRAY((AV*)sstr);
7869 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7870 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7871 SvPVX(dstr) = (char*)dst_ary;
7872 AvALLOC((AV*)dstr) = dst_ary;
7873 if (AvREAL((AV*)sstr)) {
7875 *dst_ary++ = sv_dup_inc(*src_ary++);
7879 *dst_ary++ = sv_dup(*src_ary++);
7881 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7882 while (items-- > 0) {
7883 *dst_ary++ = &PL_sv_undef;
7887 SvPVX(dstr) = Nullch;
7888 AvALLOC((AV*)dstr) = (SV**)NULL;
7892 SvANY(dstr) = new_XPVHV();
7893 SvCUR(dstr) = SvCUR(sstr);
7894 SvLEN(dstr) = SvLEN(sstr);
7895 SvIVX(dstr) = SvIVX(sstr);
7896 SvNVX(dstr) = SvNVX(sstr);
7897 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7898 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7899 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7900 if (HvARRAY((HV*)sstr)) {
7902 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7903 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7904 Newz(0, dxhv->xhv_array,
7905 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7906 while (i <= sxhv->xhv_max) {
7907 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7908 !!HvSHAREKEYS(sstr));
7911 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7914 SvPVX(dstr) = Nullch;
7915 HvEITER((HV*)dstr) = (HE*)NULL;
7917 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7918 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7921 SvANY(dstr) = new_XPVFM();
7922 FmLINES(dstr) = FmLINES(sstr);
7926 SvANY(dstr) = new_XPVCV();
7928 SvCUR(dstr) = SvCUR(sstr);
7929 SvLEN(dstr) = SvLEN(sstr);
7930 SvIVX(dstr) = SvIVX(sstr);
7931 SvNVX(dstr) = SvNVX(sstr);
7932 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7933 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7934 if (SvPVX(sstr) && SvLEN(sstr))
7935 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7937 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7938 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7939 CvSTART(dstr) = CvSTART(sstr);
7940 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7941 CvXSUB(dstr) = CvXSUB(sstr);
7942 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7943 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7944 CvDEPTH(dstr) = CvDEPTH(sstr);
7945 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7946 /* XXX padlists are real, but pretend to be not */
7947 AvREAL_on(CvPADLIST(sstr));
7948 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7949 AvREAL_off(CvPADLIST(sstr));
7950 AvREAL_off(CvPADLIST(dstr));
7953 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7954 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7955 CvFLAGS(dstr) = CvFLAGS(sstr);
7958 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7962 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7969 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7974 return (PERL_CONTEXT*)NULL;
7976 /* look for it in the table first */
7977 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7981 /* create anew and remember what it is */
7982 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7983 ptr_table_store(PL_ptr_table, cxs, ncxs);
7986 PERL_CONTEXT *cx = &cxs[ix];
7987 PERL_CONTEXT *ncx = &ncxs[ix];
7988 ncx->cx_type = cx->cx_type;
7989 if (CxTYPE(cx) == CXt_SUBST) {
7990 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7993 ncx->blk_oldsp = cx->blk_oldsp;
7994 ncx->blk_oldcop = cx->blk_oldcop;
7995 ncx->blk_oldretsp = cx->blk_oldretsp;
7996 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7997 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7998 ncx->blk_oldpm = cx->blk_oldpm;
7999 ncx->blk_gimme = cx->blk_gimme;
8000 switch (CxTYPE(cx)) {
8002 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8003 ? cv_dup_inc(cx->blk_sub.cv)
8004 : cv_dup(cx->blk_sub.cv));
8005 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8006 ? av_dup_inc(cx->blk_sub.argarray)
8008 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
8009 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8010 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8011 ncx->blk_sub.lval = cx->blk_sub.lval;
8014 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8015 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8016 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8017 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8018 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8021 ncx->blk_loop.label = cx->blk_loop.label;
8022 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8023 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8024 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8025 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8026 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8027 ? cx->blk_loop.iterdata
8028 : gv_dup((GV*)cx->blk_loop.iterdata));
8029 ncx->blk_loop.oldcurpad
8030 = (SV**)ptr_table_fetch(PL_ptr_table,
8031 cx->blk_loop.oldcurpad);
8032 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8033 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8034 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8035 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8036 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8039 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8040 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8041 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8042 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8055 Perl_si_dup(pTHX_ PERL_SI *si)
8060 return (PERL_SI*)NULL;
8062 /* look for it in the table first */
8063 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8067 /* create anew and remember what it is */
8068 Newz(56, nsi, 1, PERL_SI);
8069 ptr_table_store(PL_ptr_table, si, nsi);
8071 nsi->si_stack = av_dup_inc(si->si_stack);
8072 nsi->si_cxix = si->si_cxix;
8073 nsi->si_cxmax = si->si_cxmax;
8074 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8075 nsi->si_type = si->si_type;
8076 nsi->si_prev = si_dup(si->si_prev);
8077 nsi->si_next = si_dup(si->si_next);
8078 nsi->si_markoff = si->si_markoff;
8083 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8084 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8085 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8086 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8087 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8088 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8089 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8090 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8091 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8092 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8093 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8094 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8097 #define pv_dup_inc(p) SAVEPV(p)
8098 #define pv_dup(p) SAVEPV(p)
8099 #define svp_dup_inc(p,pp) any_dup(p,pp)
8102 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8109 /* look for it in the table first */
8110 ret = ptr_table_fetch(PL_ptr_table, v);
8114 /* see if it is part of the interpreter structure */
8115 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8116 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8124 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8126 ANY *ss = proto_perl->Tsavestack;
8127 I32 ix = proto_perl->Tsavestack_ix;
8128 I32 max = proto_perl->Tsavestack_max;
8141 void (*dptr) (void*);
8142 void (*dxptr) (pTHXo_ void*);
8145 Newz(54, nss, max, ANY);
8151 case SAVEt_ITEM: /* normal string */
8152 sv = (SV*)POPPTR(ss,ix);
8153 TOPPTR(nss,ix) = sv_dup_inc(sv);
8154 sv = (SV*)POPPTR(ss,ix);
8155 TOPPTR(nss,ix) = sv_dup_inc(sv);
8157 case SAVEt_SV: /* scalar reference */
8158 sv = (SV*)POPPTR(ss,ix);
8159 TOPPTR(nss,ix) = sv_dup_inc(sv);
8160 gv = (GV*)POPPTR(ss,ix);
8161 TOPPTR(nss,ix) = gv_dup_inc(gv);
8163 case SAVEt_GENERIC_PVREF: /* generic char* */
8164 c = (char*)POPPTR(ss,ix);
8165 TOPPTR(nss,ix) = pv_dup(c);
8166 ptr = POPPTR(ss,ix);
8167 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8169 case SAVEt_GENERIC_SVREF: /* generic sv */
8170 case SAVEt_SVREF: /* scalar reference */
8171 sv = (SV*)POPPTR(ss,ix);
8172 TOPPTR(nss,ix) = sv_dup_inc(sv);
8173 ptr = POPPTR(ss,ix);
8174 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8176 case SAVEt_AV: /* array reference */
8177 av = (AV*)POPPTR(ss,ix);
8178 TOPPTR(nss,ix) = av_dup_inc(av);
8179 gv = (GV*)POPPTR(ss,ix);
8180 TOPPTR(nss,ix) = gv_dup(gv);
8182 case SAVEt_HV: /* hash reference */
8183 hv = (HV*)POPPTR(ss,ix);
8184 TOPPTR(nss,ix) = hv_dup_inc(hv);
8185 gv = (GV*)POPPTR(ss,ix);
8186 TOPPTR(nss,ix) = gv_dup(gv);
8188 case SAVEt_INT: /* int reference */
8189 ptr = POPPTR(ss,ix);
8190 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8191 intval = (int)POPINT(ss,ix);
8192 TOPINT(nss,ix) = intval;
8194 case SAVEt_LONG: /* long reference */
8195 ptr = POPPTR(ss,ix);
8196 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8197 longval = (long)POPLONG(ss,ix);
8198 TOPLONG(nss,ix) = longval;
8200 case SAVEt_I32: /* I32 reference */
8201 case SAVEt_I16: /* I16 reference */
8202 case SAVEt_I8: /* I8 reference */
8203 ptr = POPPTR(ss,ix);
8204 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8208 case SAVEt_IV: /* IV reference */
8209 ptr = POPPTR(ss,ix);
8210 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8214 case SAVEt_SPTR: /* SV* reference */
8215 ptr = POPPTR(ss,ix);
8216 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8217 sv = (SV*)POPPTR(ss,ix);
8218 TOPPTR(nss,ix) = sv_dup(sv);
8220 case SAVEt_VPTR: /* random* reference */
8221 ptr = POPPTR(ss,ix);
8222 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8223 ptr = POPPTR(ss,ix);
8224 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8226 case SAVEt_PPTR: /* char* reference */
8227 ptr = POPPTR(ss,ix);
8228 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8229 c = (char*)POPPTR(ss,ix);
8230 TOPPTR(nss,ix) = pv_dup(c);
8232 case SAVEt_HPTR: /* HV* reference */
8233 ptr = POPPTR(ss,ix);
8234 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8235 hv = (HV*)POPPTR(ss,ix);
8236 TOPPTR(nss,ix) = hv_dup(hv);
8238 case SAVEt_APTR: /* AV* reference */
8239 ptr = POPPTR(ss,ix);
8240 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8241 av = (AV*)POPPTR(ss,ix);
8242 TOPPTR(nss,ix) = av_dup(av);
8245 gv = (GV*)POPPTR(ss,ix);
8246 TOPPTR(nss,ix) = gv_dup(gv);
8248 case SAVEt_GP: /* scalar reference */
8249 gp = (GP*)POPPTR(ss,ix);
8250 TOPPTR(nss,ix) = gp = gp_dup(gp);
8251 (void)GpREFCNT_inc(gp);
8252 gv = (GV*)POPPTR(ss,ix);
8253 TOPPTR(nss,ix) = gv_dup_inc(c);
8254 c = (char*)POPPTR(ss,ix);
8255 TOPPTR(nss,ix) = pv_dup(c);
8262 sv = (SV*)POPPTR(ss,ix);
8263 TOPPTR(nss,ix) = sv_dup_inc(sv);
8266 ptr = POPPTR(ss,ix);
8267 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8268 /* these are assumed to be refcounted properly */
8269 switch (((OP*)ptr)->op_type) {
8276 TOPPTR(nss,ix) = ptr;
8281 TOPPTR(nss,ix) = Nullop;
8286 TOPPTR(nss,ix) = Nullop;
8289 c = (char*)POPPTR(ss,ix);
8290 TOPPTR(nss,ix) = pv_dup_inc(c);
8293 longval = POPLONG(ss,ix);
8294 TOPLONG(nss,ix) = longval;
8297 hv = (HV*)POPPTR(ss,ix);
8298 TOPPTR(nss,ix) = hv_dup_inc(hv);
8299 c = (char*)POPPTR(ss,ix);
8300 TOPPTR(nss,ix) = pv_dup_inc(c);
8304 case SAVEt_DESTRUCTOR:
8305 ptr = POPPTR(ss,ix);
8306 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8307 dptr = POPDPTR(ss,ix);
8308 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8310 case SAVEt_DESTRUCTOR_X:
8311 ptr = POPPTR(ss,ix);
8312 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8313 dxptr = POPDXPTR(ss,ix);
8314 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8316 case SAVEt_REGCONTEXT:
8322 case SAVEt_STACK_POS: /* Position on Perl stack */
8326 case SAVEt_AELEM: /* array element */
8327 sv = (SV*)POPPTR(ss,ix);
8328 TOPPTR(nss,ix) = sv_dup_inc(sv);
8331 av = (AV*)POPPTR(ss,ix);
8332 TOPPTR(nss,ix) = av_dup_inc(av);
8334 case SAVEt_HELEM: /* hash element */
8335 sv = (SV*)POPPTR(ss,ix);
8336 TOPPTR(nss,ix) = sv_dup_inc(sv);
8337 sv = (SV*)POPPTR(ss,ix);
8338 TOPPTR(nss,ix) = sv_dup_inc(sv);
8339 hv = (HV*)POPPTR(ss,ix);
8340 TOPPTR(nss,ix) = hv_dup_inc(hv);
8343 ptr = POPPTR(ss,ix);
8344 TOPPTR(nss,ix) = ptr;
8351 av = (AV*)POPPTR(ss,ix);
8352 TOPPTR(nss,ix) = av_dup(av);
8355 longval = (long)POPLONG(ss,ix);
8356 TOPLONG(nss,ix) = longval;
8357 ptr = POPPTR(ss,ix);
8358 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8359 sv = (SV*)POPPTR(ss,ix);
8360 TOPPTR(nss,ix) = sv_dup(sv);
8363 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8375 perl_clone(PerlInterpreter *proto_perl, UV flags)
8378 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8381 #ifdef PERL_IMPLICIT_SYS
8382 return perl_clone_using(proto_perl, flags,
8384 proto_perl->IMemShared,
8385 proto_perl->IMemParse,
8395 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8396 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8397 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8398 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8399 struct IPerlDir* ipD, struct IPerlSock* ipS,
8400 struct IPerlProc* ipP)
8402 /* XXX many of the string copies here can be optimized if they're
8403 * constants; they need to be allocated as common memory and just
8404 * their pointers copied. */
8408 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8410 PERL_SET_THX(pPerl);
8411 # else /* !PERL_OBJECT */
8412 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8413 PERL_SET_THX(my_perl);
8416 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8421 # else /* !DEBUGGING */
8422 Zero(my_perl, 1, PerlInterpreter);
8423 # endif /* DEBUGGING */
8427 PL_MemShared = ipMS;
8435 # endif /* PERL_OBJECT */
8436 #else /* !PERL_IMPLICIT_SYS */
8438 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8439 PERL_SET_THX(my_perl);
8442 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8447 # else /* !DEBUGGING */
8448 Zero(my_perl, 1, PerlInterpreter);
8449 # endif /* DEBUGGING */
8450 #endif /* PERL_IMPLICIT_SYS */
8453 PL_xiv_arenaroot = NULL;
8455 PL_xnv_arenaroot = NULL;
8457 PL_xrv_arenaroot = NULL;
8459 PL_xpv_arenaroot = NULL;
8461 PL_xpviv_arenaroot = NULL;
8462 PL_xpviv_root = NULL;
8463 PL_xpvnv_arenaroot = NULL;
8464 PL_xpvnv_root = NULL;
8465 PL_xpvcv_arenaroot = NULL;
8466 PL_xpvcv_root = NULL;
8467 PL_xpvav_arenaroot = NULL;
8468 PL_xpvav_root = NULL;
8469 PL_xpvhv_arenaroot = NULL;
8470 PL_xpvhv_root = NULL;
8471 PL_xpvmg_arenaroot = NULL;
8472 PL_xpvmg_root = NULL;
8473 PL_xpvlv_arenaroot = NULL;
8474 PL_xpvlv_root = NULL;
8475 PL_xpvbm_arenaroot = NULL;
8476 PL_xpvbm_root = NULL;
8477 PL_he_arenaroot = NULL;
8479 PL_nice_chunk = NULL;
8480 PL_nice_chunk_size = 0;
8483 PL_sv_root = Nullsv;
8484 PL_sv_arenaroot = Nullsv;
8486 PL_debug = proto_perl->Idebug;
8488 /* create SV map for pointer relocation */
8489 PL_ptr_table = ptr_table_new();
8491 /* initialize these special pointers as early as possible */
8492 SvANY(&PL_sv_undef) = NULL;
8493 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8494 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8495 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8498 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8500 SvANY(&PL_sv_no) = new_XPVNV();
8502 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8503 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8504 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8505 SvCUR(&PL_sv_no) = 0;
8506 SvLEN(&PL_sv_no) = 1;
8507 SvNVX(&PL_sv_no) = 0;
8508 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8511 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8513 SvANY(&PL_sv_yes) = new_XPVNV();
8515 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8516 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8517 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8518 SvCUR(&PL_sv_yes) = 1;
8519 SvLEN(&PL_sv_yes) = 2;
8520 SvNVX(&PL_sv_yes) = 1;
8521 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8523 /* create shared string table */
8524 PL_strtab = newHV();
8525 HvSHAREKEYS_off(PL_strtab);
8526 hv_ksplit(PL_strtab, 512);
8527 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8529 PL_compiling = proto_perl->Icompiling;
8530 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8531 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8532 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8533 if (!specialWARN(PL_compiling.cop_warnings))
8534 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8535 if (!specialCopIO(PL_compiling.cop_io))
8536 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8537 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8539 /* pseudo environmental stuff */
8540 PL_origargc = proto_perl->Iorigargc;
8542 New(0, PL_origargv, i+1, char*);
8543 PL_origargv[i] = '\0';
8545 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8547 PL_envgv = gv_dup(proto_perl->Ienvgv);
8548 PL_incgv = gv_dup(proto_perl->Iincgv);
8549 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8550 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8551 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8552 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8555 PL_minus_c = proto_perl->Iminus_c;
8556 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8557 PL_localpatches = proto_perl->Ilocalpatches;
8558 PL_splitstr = proto_perl->Isplitstr;
8559 PL_preprocess = proto_perl->Ipreprocess;
8560 PL_minus_n = proto_perl->Iminus_n;
8561 PL_minus_p = proto_perl->Iminus_p;
8562 PL_minus_l = proto_perl->Iminus_l;
8563 PL_minus_a = proto_perl->Iminus_a;
8564 PL_minus_F = proto_perl->Iminus_F;
8565 PL_doswitches = proto_perl->Idoswitches;
8566 PL_dowarn = proto_perl->Idowarn;
8567 PL_doextract = proto_perl->Idoextract;
8568 PL_sawampersand = proto_perl->Isawampersand;
8569 PL_unsafe = proto_perl->Iunsafe;
8570 PL_inplace = SAVEPV(proto_perl->Iinplace);
8571 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8572 PL_perldb = proto_perl->Iperldb;
8573 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8575 /* magical thingies */
8576 /* XXX time(&PL_basetime) when asked for? */
8577 PL_basetime = proto_perl->Ibasetime;
8578 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8580 PL_maxsysfd = proto_perl->Imaxsysfd;
8581 PL_multiline = proto_perl->Imultiline;
8582 PL_statusvalue = proto_perl->Istatusvalue;
8584 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8587 /* shortcuts to various I/O objects */
8588 PL_stdingv = gv_dup(proto_perl->Istdingv);
8589 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8590 PL_defgv = gv_dup(proto_perl->Idefgv);
8591 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8592 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8593 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8595 /* shortcuts to regexp stuff */
8596 PL_replgv = gv_dup(proto_perl->Ireplgv);
8598 /* shortcuts to misc objects */
8599 PL_errgv = gv_dup(proto_perl->Ierrgv);
8601 /* shortcuts to debugging objects */
8602 PL_DBgv = gv_dup(proto_perl->IDBgv);
8603 PL_DBline = gv_dup(proto_perl->IDBline);
8604 PL_DBsub = gv_dup(proto_perl->IDBsub);
8605 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8606 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8607 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8608 PL_lineary = av_dup(proto_perl->Ilineary);
8609 PL_dbargs = av_dup(proto_perl->Idbargs);
8612 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8613 PL_curstash = hv_dup(proto_perl->Tcurstash);
8614 PL_debstash = hv_dup(proto_perl->Idebstash);
8615 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8616 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8618 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8619 PL_endav = av_dup_inc(proto_perl->Iendav);
8620 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8621 PL_initav = av_dup_inc(proto_perl->Iinitav);
8623 PL_sub_generation = proto_perl->Isub_generation;
8625 /* funky return mechanisms */
8626 PL_forkprocess = proto_perl->Iforkprocess;
8628 /* subprocess state */
8629 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8631 /* internal state */
8632 PL_tainting = proto_perl->Itainting;
8633 PL_maxo = proto_perl->Imaxo;
8634 if (proto_perl->Iop_mask)
8635 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8637 PL_op_mask = Nullch;
8639 /* current interpreter roots */
8640 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8641 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8642 PL_main_start = proto_perl->Imain_start;
8643 PL_eval_root = proto_perl->Ieval_root;
8644 PL_eval_start = proto_perl->Ieval_start;
8646 /* runtime control stuff */
8647 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8648 PL_copline = proto_perl->Icopline;
8650 PL_filemode = proto_perl->Ifilemode;
8651 PL_lastfd = proto_perl->Ilastfd;
8652 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8655 PL_gensym = proto_perl->Igensym;
8656 PL_preambled = proto_perl->Ipreambled;
8657 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8658 PL_laststatval = proto_perl->Ilaststatval;
8659 PL_laststype = proto_perl->Ilaststype;
8660 PL_mess_sv = Nullsv;
8662 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8663 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8665 /* interpreter atexit processing */
8666 PL_exitlistlen = proto_perl->Iexitlistlen;
8667 if (PL_exitlistlen) {
8668 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8669 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8672 PL_exitlist = (PerlExitListEntry*)NULL;
8673 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8675 PL_profiledata = NULL;
8676 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8677 /* PL_rsfp_filters entries have fake IoDIRP() */
8678 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8680 PL_compcv = cv_dup(proto_perl->Icompcv);
8681 PL_comppad = av_dup(proto_perl->Icomppad);
8682 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8683 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8684 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8685 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8686 proto_perl->Tcurpad);
8688 #ifdef HAVE_INTERP_INTERN
8689 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8692 /* more statics moved here */
8693 PL_generation = proto_perl->Igeneration;
8694 PL_DBcv = cv_dup(proto_perl->IDBcv);
8696 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8697 PL_in_clean_all = proto_perl->Iin_clean_all;
8699 PL_uid = proto_perl->Iuid;
8700 PL_euid = proto_perl->Ieuid;
8701 PL_gid = proto_perl->Igid;
8702 PL_egid = proto_perl->Iegid;
8703 PL_nomemok = proto_perl->Inomemok;
8704 PL_an = proto_perl->Ian;
8705 PL_cop_seqmax = proto_perl->Icop_seqmax;
8706 PL_op_seqmax = proto_perl->Iop_seqmax;
8707 PL_evalseq = proto_perl->Ievalseq;
8708 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8709 PL_origalen = proto_perl->Iorigalen;
8710 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8711 PL_osname = SAVEPV(proto_perl->Iosname);
8712 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8713 PL_sighandlerp = proto_perl->Isighandlerp;
8716 PL_runops = proto_perl->Irunops;
8718 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8721 PL_cshlen = proto_perl->Icshlen;
8722 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8725 PL_lex_state = proto_perl->Ilex_state;
8726 PL_lex_defer = proto_perl->Ilex_defer;
8727 PL_lex_expect = proto_perl->Ilex_expect;
8728 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8729 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8730 PL_lex_starts = proto_perl->Ilex_starts;
8731 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8732 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8733 PL_lex_op = proto_perl->Ilex_op;
8734 PL_lex_inpat = proto_perl->Ilex_inpat;
8735 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8736 PL_lex_brackets = proto_perl->Ilex_brackets;
8737 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8738 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8739 PL_lex_casemods = proto_perl->Ilex_casemods;
8740 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8741 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8743 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8744 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8745 PL_nexttoke = proto_perl->Inexttoke;
8747 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8748 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8749 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8750 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8751 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8752 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8753 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8754 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8755 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8756 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8757 PL_pending_ident = proto_perl->Ipending_ident;
8758 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8760 PL_expect = proto_perl->Iexpect;
8762 PL_multi_start = proto_perl->Imulti_start;
8763 PL_multi_end = proto_perl->Imulti_end;
8764 PL_multi_open = proto_perl->Imulti_open;
8765 PL_multi_close = proto_perl->Imulti_close;
8767 PL_error_count = proto_perl->Ierror_count;
8768 PL_subline = proto_perl->Isubline;
8769 PL_subname = sv_dup_inc(proto_perl->Isubname);
8771 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8772 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8773 PL_padix = proto_perl->Ipadix;
8774 PL_padix_floor = proto_perl->Ipadix_floor;
8775 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8777 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8778 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8779 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8780 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8781 PL_last_lop_op = proto_perl->Ilast_lop_op;
8782 PL_in_my = proto_perl->Iin_my;
8783 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8785 PL_cryptseen = proto_perl->Icryptseen;
8788 PL_hints = proto_perl->Ihints;
8790 PL_amagic_generation = proto_perl->Iamagic_generation;
8792 #ifdef USE_LOCALE_COLLATE
8793 PL_collation_ix = proto_perl->Icollation_ix;
8794 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8795 PL_collation_standard = proto_perl->Icollation_standard;
8796 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8797 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8798 #endif /* USE_LOCALE_COLLATE */
8800 #ifdef USE_LOCALE_NUMERIC
8801 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8802 PL_numeric_standard = proto_perl->Inumeric_standard;
8803 PL_numeric_local = proto_perl->Inumeric_local;
8804 PL_numeric_radix = proto_perl->Inumeric_radix;
8805 #endif /* !USE_LOCALE_NUMERIC */
8807 /* utf8 character classes */
8808 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8809 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8810 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8811 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8812 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8813 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8814 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8815 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8816 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8817 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8818 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8819 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8820 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8821 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8822 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8823 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8824 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8827 PL_last_swash_hv = Nullhv; /* reinits on demand */
8828 PL_last_swash_klen = 0;
8829 PL_last_swash_key[0]= '\0';
8830 PL_last_swash_tmps = (U8*)NULL;
8831 PL_last_swash_slen = 0;
8833 /* perly.c globals */
8834 PL_yydebug = proto_perl->Iyydebug;
8835 PL_yynerrs = proto_perl->Iyynerrs;
8836 PL_yyerrflag = proto_perl->Iyyerrflag;
8837 PL_yychar = proto_perl->Iyychar;
8838 PL_yyval = proto_perl->Iyyval;
8839 PL_yylval = proto_perl->Iyylval;
8841 PL_glob_index = proto_perl->Iglob_index;
8842 PL_srand_called = proto_perl->Isrand_called;
8843 PL_uudmap['M'] = 0; /* reinits on demand */
8844 PL_bitcount = Nullch; /* reinits on demand */
8846 if (proto_perl->Ipsig_ptr) {
8847 int sig_num[] = { SIG_NUM };
8848 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8849 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8850 for (i = 1; PL_sig_name[i]; i++) {
8851 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8852 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8856 PL_psig_ptr = (SV**)NULL;
8857 PL_psig_name = (SV**)NULL;
8860 /* thrdvar.h stuff */
8863 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8864 PL_tmps_ix = proto_perl->Ttmps_ix;
8865 PL_tmps_max = proto_perl->Ttmps_max;
8866 PL_tmps_floor = proto_perl->Ttmps_floor;
8867 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8869 while (i <= PL_tmps_ix) {
8870 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8874 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8875 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8876 Newz(54, PL_markstack, i, I32);
8877 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8878 - proto_perl->Tmarkstack);
8879 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8880 - proto_perl->Tmarkstack);
8881 Copy(proto_perl->Tmarkstack, PL_markstack,
8882 PL_markstack_ptr - PL_markstack + 1, I32);
8884 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8885 * NOTE: unlike the others! */
8886 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8887 PL_scopestack_max = proto_perl->Tscopestack_max;
8888 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8889 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8891 /* next push_return() sets PL_retstack[PL_retstack_ix]
8892 * NOTE: unlike the others! */
8893 PL_retstack_ix = proto_perl->Tretstack_ix;
8894 PL_retstack_max = proto_perl->Tretstack_max;
8895 Newz(54, PL_retstack, PL_retstack_max, OP*);
8896 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8898 /* NOTE: si_dup() looks at PL_markstack */
8899 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8901 /* PL_curstack = PL_curstackinfo->si_stack; */
8902 PL_curstack = av_dup(proto_perl->Tcurstack);
8903 PL_mainstack = av_dup(proto_perl->Tmainstack);
8905 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8906 PL_stack_base = AvARRAY(PL_curstack);
8907 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8908 - proto_perl->Tstack_base);
8909 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8911 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8912 * NOTE: unlike the others! */
8913 PL_savestack_ix = proto_perl->Tsavestack_ix;
8914 PL_savestack_max = proto_perl->Tsavestack_max;
8915 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8916 PL_savestack = ss_dup(proto_perl);
8920 ENTER; /* perl_destruct() wants to LEAVE; */
8923 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8924 PL_top_env = &PL_start_env;
8926 PL_op = proto_perl->Top;
8929 PL_Xpv = (XPV*)NULL;
8930 PL_na = proto_perl->Tna;
8932 PL_statbuf = proto_perl->Tstatbuf;
8933 PL_statcache = proto_perl->Tstatcache;
8934 PL_statgv = gv_dup(proto_perl->Tstatgv);
8935 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8937 PL_timesbuf = proto_perl->Ttimesbuf;
8940 PL_tainted = proto_perl->Ttainted;
8941 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8942 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8943 PL_rs = sv_dup_inc(proto_perl->Trs);
8944 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8945 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
8946 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8947 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8948 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8949 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8950 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8952 PL_restartop = proto_perl->Trestartop;
8953 PL_in_eval = proto_perl->Tin_eval;
8954 PL_delaymagic = proto_perl->Tdelaymagic;
8955 PL_dirty = proto_perl->Tdirty;
8956 PL_localizing = proto_perl->Tlocalizing;
8958 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8959 PL_protect = proto_perl->Tprotect;
8961 PL_errors = sv_dup_inc(proto_perl->Terrors);
8962 PL_av_fetch_sv = Nullsv;
8963 PL_hv_fetch_sv = Nullsv;
8964 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8965 PL_modcount = proto_perl->Tmodcount;
8966 PL_lastgotoprobe = Nullop;
8967 PL_dumpindent = proto_perl->Tdumpindent;
8969 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8970 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8971 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8972 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8973 PL_sortcxix = proto_perl->Tsortcxix;
8974 PL_efloatbuf = Nullch; /* reinits on demand */
8975 PL_efloatsize = 0; /* reinits on demand */
8979 PL_screamfirst = NULL;
8980 PL_screamnext = NULL;
8981 PL_maxscream = -1; /* reinits on demand */
8982 PL_lastscream = Nullsv;
8984 PL_watchaddr = NULL;
8985 PL_watchok = Nullch;
8987 PL_regdummy = proto_perl->Tregdummy;
8988 PL_regcomp_parse = Nullch;
8989 PL_regxend = Nullch;
8990 PL_regcode = (regnode*)NULL;
8993 PL_regprecomp = Nullch;
8998 PL_seen_zerolen = 0;
9000 PL_regcomp_rx = (regexp*)NULL;
9002 PL_colorset = 0; /* reinits PL_colors[] */
9003 /*PL_colors[6] = {0,0,0,0,0,0};*/
9004 PL_reg_whilem_seen = 0;
9005 PL_reginput = Nullch;
9008 PL_regstartp = (I32*)NULL;
9009 PL_regendp = (I32*)NULL;
9010 PL_reglastparen = (U32*)NULL;
9011 PL_regtill = Nullch;
9013 PL_reg_start_tmp = (char**)NULL;
9014 PL_reg_start_tmpl = 0;
9015 PL_regdata = (struct reg_data*)NULL;
9018 PL_reg_eval_set = 0;
9020 PL_regprogram = (regnode*)NULL;
9022 PL_regcc = (CURCUR*)NULL;
9023 PL_reg_call_cc = (struct re_cc_state*)NULL;
9024 PL_reg_re = (regexp*)NULL;
9025 PL_reg_ganch = Nullch;
9027 PL_reg_magic = (MAGIC*)NULL;
9029 PL_reg_oldcurpm = (PMOP*)NULL;
9030 PL_reg_curpm = (PMOP*)NULL;
9031 PL_reg_oldsaved = Nullch;
9032 PL_reg_oldsavedlen = 0;
9034 PL_reg_leftiter = 0;
9035 PL_reg_poscache = Nullch;
9036 PL_reg_poscache_size= 0;
9038 /* RE engine - function pointers */
9039 PL_regcompp = proto_perl->Tregcompp;
9040 PL_regexecp = proto_perl->Tregexecp;
9041 PL_regint_start = proto_perl->Tregint_start;
9042 PL_regint_string = proto_perl->Tregint_string;
9043 PL_regfree = proto_perl->Tregfree;
9045 PL_reginterp_cnt = 0;
9046 PL_reg_starttry = 0;
9049 return (PerlInterpreter*)pPerl;
9055 #else /* !USE_ITHREADS */
9061 #endif /* USE_ITHREADS */
9064 do_report_used(pTHXo_ SV *sv)
9066 if (SvTYPE(sv) != SVTYPEMASK) {
9067 PerlIO_printf(Perl_debug_log, "****\n");
9073 do_clean_objs(pTHXo_ SV *sv)
9077 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9078 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9079 if (SvWEAKREF(sv)) {
9090 /* XXX Might want to check arrays, etc. */
9093 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9095 do_clean_named_objs(pTHXo_ SV *sv)
9097 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9098 if ( SvOBJECT(GvSV(sv)) ||
9099 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9100 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9101 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9102 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9104 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9112 do_clean_all(pTHXo_ SV *sv)
9114 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9115 SvFLAGS(sv) |= SVf_BREAK;