3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
29 * "A time to plant, and a time to uproot what was planted..."
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
40 /* sv_mutex must be held while calling uproot_SV() */
41 #define uproot_SV(p) \
44 PL_sv_root = (SV*)SvANY(p); \
66 if (PL_debug & 32768) \
76 if (PL_debug & 32768) {
81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
83 svend = &sva[SvREFCNT(sva)];
84 if (p >= sv && p < svend)
88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
90 "Attempt to free non-arena SV: 0x%"UVxf,
98 #else /* ! DEBUGGING */
100 #define del_SV(p) plant_SV(p)
102 #endif /* DEBUGGING */
105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
110 Zero(ptr, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
197 XPV *arena, *arenanext;
199 /* Free arenas here, but be careful about fake ones. (We assume
200 contiguity of the fake ones with the corresponding real ones.) */
202 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
203 svanext = (SV*) SvANY(sva);
204 while (svanext && SvFAKE(svanext))
205 svanext = (SV*) SvANY(svanext);
208 Safefree((void *)sva);
211 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
212 arenanext = (XPV*)arena->xpv_pv;
215 PL_xiv_arenaroot = 0;
217 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
218 arenanext = (XPV*)arena->xpv_pv;
221 PL_xnv_arenaroot = 0;
223 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
224 arenanext = (XPV*)arena->xpv_pv;
227 PL_xrv_arenaroot = 0;
229 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
230 arenanext = (XPV*)arena->xpv_pv;
233 PL_xpv_arenaroot = 0;
235 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
236 arenanext = (XPV*)arena->xpv_pv;
239 PL_xpviv_arenaroot = 0;
241 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
242 arenanext = (XPV*)arena->xpv_pv;
245 PL_xpvnv_arenaroot = 0;
247 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
248 arenanext = (XPV*)arena->xpv_pv;
251 PL_xpvcv_arenaroot = 0;
253 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
254 arenanext = (XPV*)arena->xpv_pv;
257 PL_xpvav_arenaroot = 0;
259 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
260 arenanext = (XPV*)arena->xpv_pv;
263 PL_xpvhv_arenaroot = 0;
265 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
266 arenanext = (XPV*)arena->xpv_pv;
269 PL_xpvmg_arenaroot = 0;
271 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
272 arenanext = (XPV*)arena->xpv_pv;
275 PL_xpvlv_arenaroot = 0;
277 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
278 arenanext = (XPV*)arena->xpv_pv;
281 PL_xpvbm_arenaroot = 0;
283 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
284 arenanext = (XPV*)arena->xpv_pv;
290 Safefree(PL_nice_chunk);
291 PL_nice_chunk = Nullch;
292 PL_nice_chunk_size = 0;
298 Perl_report_uninit(pTHX)
301 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
302 " in ", PL_op_desc[PL_op->op_type]);
304 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
316 * See comment in more_xiv() -- RAM.
318 PL_xiv_root = *(IV**)xiv;
320 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
324 S_del_xiv(pTHX_ XPVIV *p)
326 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
328 *(IV**)xiv = PL_xiv_root;
339 New(705, ptr, 1008/sizeof(XPV), XPV);
340 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
341 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
344 xivend = &xiv[1008 / sizeof(IV) - 1];
345 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
347 while (xiv < xivend) {
348 *(IV**)xiv = (IV *)(xiv + 1);
362 PL_xnv_root = *(NV**)xnv;
364 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
368 S_del_xnv(pTHX_ XPVNV *p)
370 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
372 *(NV**)xnv = PL_xnv_root;
383 New(711, ptr, 1008/sizeof(XPV), XPV);
384 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
385 PL_xnv_arenaroot = ptr;
388 xnvend = &xnv[1008 / sizeof(NV) - 1];
389 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
391 while (xnv < xnvend) {
392 *(NV**)xnv = (NV*)(xnv + 1);
406 PL_xrv_root = (XRV*)xrv->xrv_rv;
412 S_del_xrv(pTHX_ XRV *p)
415 p->xrv_rv = (SV*)PL_xrv_root;
424 register XRV* xrvend;
426 New(712, ptr, 1008/sizeof(XPV), XPV);
427 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
428 PL_xrv_arenaroot = ptr;
431 xrvend = &xrv[1008 / sizeof(XRV) - 1];
432 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
434 while (xrv < xrvend) {
435 xrv->xrv_rv = (SV*)(xrv + 1);
449 PL_xpv_root = (XPV*)xpv->xpv_pv;
455 S_del_xpv(pTHX_ XPV *p)
458 p->xpv_pv = (char*)PL_xpv_root;
467 register XPV* xpvend;
468 New(713, xpv, 1008/sizeof(XPV), XPV);
469 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
470 PL_xpv_arenaroot = xpv;
472 xpvend = &xpv[1008 / sizeof(XPV) - 1];
474 while (xpv < xpvend) {
475 xpv->xpv_pv = (char*)(xpv + 1);
488 xpviv = PL_xpviv_root;
489 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
495 S_del_xpviv(pTHX_ XPVIV *p)
498 p->xpv_pv = (char*)PL_xpviv_root;
506 register XPVIV* xpviv;
507 register XPVIV* xpvivend;
508 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
509 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
510 PL_xpviv_arenaroot = xpviv;
512 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
513 PL_xpviv_root = ++xpviv;
514 while (xpviv < xpvivend) {
515 xpviv->xpv_pv = (char*)(xpviv + 1);
528 xpvnv = PL_xpvnv_root;
529 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
535 S_del_xpvnv(pTHX_ XPVNV *p)
538 p->xpv_pv = (char*)PL_xpvnv_root;
546 register XPVNV* xpvnv;
547 register XPVNV* xpvnvend;
548 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
549 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
550 PL_xpvnv_arenaroot = xpvnv;
552 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
553 PL_xpvnv_root = ++xpvnv;
554 while (xpvnv < xpvnvend) {
555 xpvnv->xpv_pv = (char*)(xpvnv + 1);
568 xpvcv = PL_xpvcv_root;
569 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
575 S_del_xpvcv(pTHX_ XPVCV *p)
578 p->xpv_pv = (char*)PL_xpvcv_root;
586 register XPVCV* xpvcv;
587 register XPVCV* xpvcvend;
588 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
589 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
590 PL_xpvcv_arenaroot = xpvcv;
592 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
593 PL_xpvcv_root = ++xpvcv;
594 while (xpvcv < xpvcvend) {
595 xpvcv->xpv_pv = (char*)(xpvcv + 1);
608 xpvav = PL_xpvav_root;
609 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
615 S_del_xpvav(pTHX_ XPVAV *p)
618 p->xav_array = (char*)PL_xpvav_root;
626 register XPVAV* xpvav;
627 register XPVAV* xpvavend;
628 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
629 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
630 PL_xpvav_arenaroot = xpvav;
632 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
633 PL_xpvav_root = ++xpvav;
634 while (xpvav < xpvavend) {
635 xpvav->xav_array = (char*)(xpvav + 1);
638 xpvav->xav_array = 0;
648 xpvhv = PL_xpvhv_root;
649 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
655 S_del_xpvhv(pTHX_ XPVHV *p)
658 p->xhv_array = (char*)PL_xpvhv_root;
666 register XPVHV* xpvhv;
667 register XPVHV* xpvhvend;
668 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
669 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
670 PL_xpvhv_arenaroot = xpvhv;
672 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
673 PL_xpvhv_root = ++xpvhv;
674 while (xpvhv < xpvhvend) {
675 xpvhv->xhv_array = (char*)(xpvhv + 1);
678 xpvhv->xhv_array = 0;
688 xpvmg = PL_xpvmg_root;
689 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
695 S_del_xpvmg(pTHX_ XPVMG *p)
698 p->xpv_pv = (char*)PL_xpvmg_root;
706 register XPVMG* xpvmg;
707 register XPVMG* xpvmgend;
708 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
709 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
710 PL_xpvmg_arenaroot = xpvmg;
712 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
713 PL_xpvmg_root = ++xpvmg;
714 while (xpvmg < xpvmgend) {
715 xpvmg->xpv_pv = (char*)(xpvmg + 1);
728 xpvlv = PL_xpvlv_root;
729 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
735 S_del_xpvlv(pTHX_ XPVLV *p)
738 p->xpv_pv = (char*)PL_xpvlv_root;
746 register XPVLV* xpvlv;
747 register XPVLV* xpvlvend;
748 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
749 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
750 PL_xpvlv_arenaroot = xpvlv;
752 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
753 PL_xpvlv_root = ++xpvlv;
754 while (xpvlv < xpvlvend) {
755 xpvlv->xpv_pv = (char*)(xpvlv + 1);
768 xpvbm = PL_xpvbm_root;
769 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
775 S_del_xpvbm(pTHX_ XPVBM *p)
778 p->xpv_pv = (char*)PL_xpvbm_root;
786 register XPVBM* xpvbm;
787 register XPVBM* xpvbmend;
788 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
789 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
790 PL_xpvbm_arenaroot = xpvbm;
792 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
793 PL_xpvbm_root = ++xpvbm;
794 while (xpvbm < xpvbmend) {
795 xpvbm->xpv_pv = (char*)(xpvbm + 1);
802 # define my_safemalloc(s) (void*)safexmalloc(717,s)
803 # define my_safefree(p) safexfree((char*)p)
805 # define my_safemalloc(s) (void*)safemalloc(s)
806 # define my_safefree(p) safefree((char*)p)
811 #define new_XIV() my_safemalloc(sizeof(XPVIV))
812 #define del_XIV(p) my_safefree(p)
814 #define new_XNV() my_safemalloc(sizeof(XPVNV))
815 #define del_XNV(p) my_safefree(p)
817 #define new_XRV() my_safemalloc(sizeof(XRV))
818 #define del_XRV(p) my_safefree(p)
820 #define new_XPV() my_safemalloc(sizeof(XPV))
821 #define del_XPV(p) my_safefree(p)
823 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
824 #define del_XPVIV(p) my_safefree(p)
826 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
827 #define del_XPVNV(p) my_safefree(p)
829 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
830 #define del_XPVCV(p) my_safefree(p)
832 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
833 #define del_XPVAV(p) my_safefree(p)
835 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
836 #define del_XPVHV(p) my_safefree(p)
838 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
839 #define del_XPVMG(p) my_safefree(p)
841 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
842 #define del_XPVLV(p) my_safefree(p)
844 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
845 #define del_XPVBM(p) my_safefree(p)
849 #define new_XIV() (void*)new_xiv()
850 #define del_XIV(p) del_xiv((XPVIV*) p)
852 #define new_XNV() (void*)new_xnv()
853 #define del_XNV(p) del_xnv((XPVNV*) p)
855 #define new_XRV() (void*)new_xrv()
856 #define del_XRV(p) del_xrv((XRV*) p)
858 #define new_XPV() (void*)new_xpv()
859 #define del_XPV(p) del_xpv((XPV *)p)
861 #define new_XPVIV() (void*)new_xpviv()
862 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
864 #define new_XPVNV() (void*)new_xpvnv()
865 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
867 #define new_XPVCV() (void*)new_xpvcv()
868 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
870 #define new_XPVAV() (void*)new_xpvav()
871 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
873 #define new_XPVHV() (void*)new_xpvhv()
874 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
876 #define new_XPVMG() (void*)new_xpvmg()
877 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
879 #define new_XPVLV() (void*)new_xpvlv()
880 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
882 #define new_XPVBM() (void*)new_xpvbm()
883 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
887 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
888 #define del_XPVGV(p) my_safefree(p)
890 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
891 #define del_XPVFM(p) my_safefree(p)
893 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
894 #define del_XPVIO(p) my_safefree(p)
897 =for apidoc sv_upgrade
899 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
906 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
916 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
920 if (SvTYPE(sv) == mt)
926 switch (SvTYPE(sv)) {
947 else if (mt < SVt_PVIV)
964 pv = (char*)SvRV(sv);
984 else if (mt == SVt_NV)
995 del_XPVIV(SvANY(sv));
1005 del_XPVNV(SvANY(sv));
1013 magic = SvMAGIC(sv);
1014 stash = SvSTASH(sv);
1015 del_XPVMG(SvANY(sv));
1018 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1023 Perl_croak(aTHX_ "Can't upgrade to undef");
1025 SvANY(sv) = new_XIV();
1029 SvANY(sv) = new_XNV();
1033 SvANY(sv) = new_XRV();
1037 SvANY(sv) = new_XPV();
1043 SvANY(sv) = new_XPVIV();
1053 SvANY(sv) = new_XPVNV();
1061 SvANY(sv) = new_XPVMG();
1067 SvMAGIC(sv) = magic;
1068 SvSTASH(sv) = stash;
1071 SvANY(sv) = new_XPVLV();
1077 SvMAGIC(sv) = magic;
1078 SvSTASH(sv) = stash;
1085 SvANY(sv) = new_XPVAV();
1093 SvMAGIC(sv) = magic;
1094 SvSTASH(sv) = stash;
1100 SvANY(sv) = new_XPVHV();
1108 SvMAGIC(sv) = magic;
1109 SvSTASH(sv) = stash;
1116 SvANY(sv) = new_XPVCV();
1117 Zero(SvANY(sv), 1, XPVCV);
1123 SvMAGIC(sv) = magic;
1124 SvSTASH(sv) = stash;
1127 SvANY(sv) = new_XPVGV();
1133 SvMAGIC(sv) = magic;
1134 SvSTASH(sv) = stash;
1142 SvANY(sv) = new_XPVBM();
1148 SvMAGIC(sv) = magic;
1149 SvSTASH(sv) = stash;
1155 SvANY(sv) = new_XPVFM();
1156 Zero(SvANY(sv), 1, XPVFM);
1162 SvMAGIC(sv) = magic;
1163 SvSTASH(sv) = stash;
1166 SvANY(sv) = new_XPVIO();
1167 Zero(SvANY(sv), 1, XPVIO);
1173 SvMAGIC(sv) = magic;
1174 SvSTASH(sv) = stash;
1175 IoPAGE_LEN(sv) = 60;
1178 SvFLAGS(sv) &= ~SVTYPEMASK;
1184 Perl_sv_backoff(pTHX_ register SV *sv)
1188 char *s = SvPVX(sv);
1189 SvLEN(sv) += SvIVX(sv);
1190 SvPVX(sv) -= SvIVX(sv);
1192 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1194 SvFLAGS(sv) &= ~SVf_OOK;
1201 Expands the character buffer in the SV. This will use C<sv_unref> and will
1202 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1209 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1213 #ifdef HAS_64K_LIMIT
1214 if (newlen >= 0x10000) {
1215 PerlIO_printf(Perl_debug_log,
1216 "Allocation too large: %"UVxf"\n", (UV)newlen);
1219 #endif /* HAS_64K_LIMIT */
1222 if (SvTYPE(sv) < SVt_PV) {
1223 sv_upgrade(sv, SVt_PV);
1226 else if (SvOOK(sv)) { /* pv is offset? */
1229 if (newlen > SvLEN(sv))
1230 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1231 #ifdef HAS_64K_LIMIT
1232 if (newlen >= 0x10000)
1238 if (newlen > SvLEN(sv)) { /* need more room? */
1239 if (SvLEN(sv) && s) {
1240 #if defined(MYMALLOC) && !defined(LEAKTEST)
1241 STRLEN l = malloced_size((void*)SvPVX(sv));
1247 Renew(s,newlen,char);
1250 New(703,s,newlen,char);
1252 SvLEN_set(sv, newlen);
1258 =for apidoc sv_setiv
1260 Copies an integer into the given SV. Does not handle 'set' magic. See
1267 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1269 SV_CHECK_THINKFIRST(sv);
1270 switch (SvTYPE(sv)) {
1272 sv_upgrade(sv, SVt_IV);
1275 sv_upgrade(sv, SVt_PVNV);
1279 sv_upgrade(sv, SVt_PVIV);
1288 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1289 PL_op_desc[PL_op->op_type]);
1291 (void)SvIOK_only(sv); /* validate number */
1297 =for apidoc sv_setiv_mg
1299 Like C<sv_setiv>, but also handles 'set' magic.
1305 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1312 =for apidoc sv_setuv
1314 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1321 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1323 /* With these two if statements:
1324 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1327 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1329 If you wish to remove them, please benchmark to see what the effect is
1331 if (u <= (UV)IV_MAX) {
1332 sv_setiv(sv, (IV)u);
1341 =for apidoc sv_setuv_mg
1343 Like C<sv_setuv>, but also handles 'set' magic.
1349 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1351 /* With these two if statements:
1352 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1355 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1357 If you wish to remove them, please benchmark to see what the effect is
1359 if (u <= (UV)IV_MAX) {
1360 sv_setiv(sv, (IV)u);
1370 =for apidoc sv_setnv
1372 Copies a double into the given SV. Does not handle 'set' magic. See
1379 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1381 SV_CHECK_THINKFIRST(sv);
1382 switch (SvTYPE(sv)) {
1385 sv_upgrade(sv, SVt_NV);
1390 sv_upgrade(sv, SVt_PVNV);
1399 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1400 PL_op_name[PL_op->op_type]);
1403 (void)SvNOK_only(sv); /* validate number */
1408 =for apidoc sv_setnv_mg
1410 Like C<sv_setnv>, but also handles 'set' magic.
1416 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1423 S_not_a_number(pTHX_ SV *sv)
1428 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1429 /* each *s can expand to 4 chars + "...\0",
1430 i.e. need room for 8 chars */
1432 for (s = SvPVX(sv); *s && d < limit; s++) {
1434 if (ch & 128 && !isPRINT_LC(ch)) {
1443 else if (ch == '\r') {
1447 else if (ch == '\f') {
1451 else if (ch == '\\') {
1455 else if (isPRINT_LC(ch))
1470 Perl_warner(aTHX_ WARN_NUMERIC,
1471 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1472 PL_op_desc[PL_op->op_type]);
1474 Perl_warner(aTHX_ WARN_NUMERIC,
1475 "Argument \"%s\" isn't numeric", tmpbuf);
1478 /* the number can be converted to integer with atol() or atoll() although */
1479 #define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
1480 #define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
1481 #define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
1482 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1483 #define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
1484 #define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
1485 #define IS_NUMBER_NEG 0x40 /* seen a leading - */
1486 #define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
1488 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1489 until proven guilty, assume that things are not that bad... */
1491 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1492 an IV (an assumption perl has been based on to date) it becomes necessary
1493 to remove the assumption that the NV always carries enough precision to
1494 recreate the IV whenever needed, and that the NV is the canonical form.
1495 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1496 precision as an side effect of conversion (which would lead to insanity
1497 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1498 1) to distinguish between IV/UV/NV slots that have cached a valid
1499 conversion where precision was lost and IV/UV/NV slots that have a
1500 valid conversion which has lost no precision
1501 2) to ensure that if a numeric conversion to one form is request that
1502 would lose precision, the precise conversion (or differently
1503 imprecise conversion) is also performed and cached, to prevent
1504 requests for different numeric formats on the same SV causing
1505 lossy conversion chains. (lossless conversion chains are perfectly
1510 SvIOKp is true if the IV slot contains a valid value
1511 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1512 SvNOKp is true if the NV slot contains a valid value
1513 SvNOK is true only if the NV value is accurate
1516 while converting from PV to NV check to see if converting that NV to an
1517 IV(or UV) would lose accuracy over a direct conversion from PV to
1518 IV(or UV). If it would, cache both conversions, return NV, but mark
1519 SV as IOK NOKp (ie not NOK).
1521 while converting from PV to IV check to see if converting that IV to an
1522 NV would lose accuracy over a direct conversion from PV to NV. If it
1523 would, cache both conversions, flag similarly.
1525 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1526 correctly because if IV & NV were set NV *always* overruled.
1527 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1528 changes - now IV and NV together means that the two are interchangeable
1529 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1531 The benefit of this is operations such as pp_add know that if SvIOK is
1532 true for both left and right operands, then integer addition can be
1533 used instead of floating point. (for cases where the result won't
1534 overflow) Before, floating point was always used, which could lead to
1535 loss of precision compared with integer addition.
1537 * making IV and NV equal status should make maths accurate on 64 bit
1539 * may speed up maths somewhat if pp_add and friends start to use
1540 integers when possible instead of fp. (hopefully the overhead in
1541 looking for SvIOK and checking for overflow will not outweigh the
1542 fp to integer speedup)
1543 * will slow down integer operations (callers of SvIV) on "inaccurate"
1544 values, as the change from SvIOK to SvIOKp will cause a call into
1545 sv_2iv each time rather than a macro access direct to the IV slot
1546 * should speed up number->string conversion on integers as IV is
1547 favoured when IV and NV equally accurate
1549 ####################################################################
1550 You had better be using SvIOK_notUV if you want an IV for arithmetic
1551 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1552 SvUOK is true iff UV.
1553 ####################################################################
1555 Your mileage will vary depending your CPUs relative fp to integer
1559 #ifndef NV_PRESERVES_UV
1560 #define IS_NUMBER_UNDERFLOW_IV 1
1561 #define IS_NUMBER_UNDERFLOW_UV 2
1562 #define IS_NUMBER_IV_AND_UV 2
1563 #define IS_NUMBER_OVERFLOW_IV 4
1564 #define IS_NUMBER_OVERFLOW_UV 5
1565 /* Hopefully your optimiser will consider inlining these two functions. */
1567 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1568 NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
1569 UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
1570 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype));
1571 if (nv_as_uv <= (UV)IV_MAX) {
1572 (void)SvIOKp_on(sv);
1573 (void)SvNOKp_on(sv);
1574 /* Within suitable range to fit in an IV, atol won't overflow */
1575 /* XXX quite sure? Is that your final answer? not really, I'm
1576 trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1577 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1578 if (numtype & IS_NUMBER_NOT_INT) {
1579 /* I believe that even if the original PV had decimals, they
1580 are lost beyond the limit of the FP precision.
1581 However, neither is canonical, so both only get p flags.
1583 /* Both already have p flags, so do nothing */
1584 } else if (SvIVX(sv) == I_V(nv)) {
1589 /* It had no "." so it must be integer. assert (get in here from
1590 sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1591 IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1592 conversion routines need audit. */
1594 return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1596 /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1597 (void)SvIOKp_on(sv);
1598 (void)SvNOKp_on(sv);
1601 int save_errno = errno;
1603 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1605 if (numtype & IS_NUMBER_NOT_INT) {
1606 /* UV and NV both imprecise. */
1608 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1617 return IS_NUMBER_OVERFLOW_IV;
1621 /* Must have just overflowed UV, but not enough that an NV could spot
1623 return IS_NUMBER_OVERFLOW_UV;
1626 /* We've just lost integer precision, nothing we could do. */
1627 SvUVX(sv) = nv_as_uv;
1628 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype));
1629 /* UV and NV slots equally valid only if we have casting symmetry. */
1630 if (numtype & IS_NUMBER_NOT_INT) {
1632 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1633 /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1634 UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1635 get to this point if NVs don't preserve UVs) */
1640 /* As above, I believe UV at least as good as NV */
1643 #endif /* HAS_STRTOUL */
1644 return IS_NUMBER_OVERFLOW_IV;
1647 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1649 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1651 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype));
1652 if (SvNVX(sv) < (NV)IV_MIN) {
1653 (void)SvIOKp_on(sv);
1656 return IS_NUMBER_UNDERFLOW_IV;
1658 if (SvNVX(sv) > (NV)UV_MAX) {
1659 (void)SvIOKp_on(sv);
1663 return IS_NUMBER_OVERFLOW_UV;
1665 if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1666 (void)SvIOKp_on(sv);
1668 /* Can't use strtol etc to convert this string */
1669 if (SvNVX(sv) <= (UV)IV_MAX) {
1670 SvIVX(sv) = I_V(SvNVX(sv));
1671 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1672 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1674 /* Integer is imprecise. NOK, IOKp */
1676 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1679 SvUVX(sv) = U_V(SvNVX(sv));
1680 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1681 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1683 /* Integer is imprecise. NOK, IOKp */
1685 return IS_NUMBER_OVERFLOW_IV;
1687 return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
1689 #endif /* NV_PRESERVES_UV*/
1692 Perl_sv_2iv(pTHX_ register SV *sv)
1696 if (SvGMAGICAL(sv)) {
1701 return I_V(SvNVX(sv));
1703 if (SvPOKp(sv) && SvLEN(sv))
1706 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1707 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1713 if (SvTHINKFIRST(sv)) {
1716 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1717 (SvRV(tmpstr) != SvRV(sv)))
1718 return SvIV(tmpstr);
1719 return PTR2IV(SvRV(sv));
1721 if (SvREADONLY(sv) && SvFAKE(sv)) {
1722 sv_force_normal(sv);
1724 if (SvREADONLY(sv) && !SvOK(sv)) {
1725 if (ckWARN(WARN_UNINITIALIZED))
1732 return (IV)(SvUVX(sv));
1739 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1740 * without also getting a cached IV/UV from it at the same time
1741 * (ie PV->NV conversion should detect loss of accuracy and cache
1742 * IV or UV at same time to avoid this. NWC */
1744 if (SvTYPE(sv) == SVt_NV)
1745 sv_upgrade(sv, SVt_PVNV);
1747 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1748 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1749 certainly cast into the IV range at IV_MAX, whereas the correct
1750 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1752 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1753 SvIVX(sv) = I_V(SvNVX(sv));
1754 if (SvNVX(sv) == (NV) SvIVX(sv)
1755 #ifndef NV_PRESERVES_UV
1756 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1757 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1758 /* Don't flag it as "accurately an integer" if the number
1759 came from a (by definition imprecise) NV operation, and
1760 we're outside the range of NV integer precision */
1763 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1764 DEBUG_c(PerlIO_printf(Perl_debug_log,
1765 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1771 /* IV not precise. No need to convert from PV, as NV
1772 conversion would already have cached IV if it detected
1773 that PV->IV would be better than PV->NV->IV
1774 flags already correct - don't set public IOK. */
1775 DEBUG_c(PerlIO_printf(Perl_debug_log,
1776 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1781 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1782 but the cast (NV)IV_MIN rounds to a the value less (more
1783 negative) than IV_MIN which happens to be equal to SvNVX ??
1784 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1785 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1786 (NV)UVX == NVX are both true, but the values differ. :-(
1787 Hopefully for 2s complement IV_MIN is something like
1788 0x8000000000000000 which will be exact. NWC */
1791 SvUVX(sv) = U_V(SvNVX(sv));
1793 (SvNVX(sv) == (NV) SvUVX(sv))
1794 #ifndef NV_PRESERVES_UV
1795 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1796 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1797 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1798 /* Don't flag it as "accurately an integer" if the number
1799 came from a (by definition imprecise) NV operation, and
1800 we're outside the range of NV integer precision */
1806 DEBUG_c(PerlIO_printf(Perl_debug_log,
1807 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1811 return (IV)SvUVX(sv);
1814 else if (SvPOKp(sv) && SvLEN(sv)) {
1815 I32 numtype = looks_like_number(sv);
1817 /* We want to avoid a possible problem when we cache an IV which
1818 may be later translated to an NV, and the resulting NV is not
1819 the translation of the initial data.
1821 This means that if we cache such an IV, we need to cache the
1822 NV as well. Moreover, we trade speed for space, and do not
1823 cache the NV if we are sure it's not needed.
1826 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1827 /* The NV may be reconstructed from IV - safe to cache IV,
1828 which may be calculated by atol(). */
1829 if (SvTYPE(sv) < SVt_PVIV)
1830 sv_upgrade(sv, SVt_PVIV);
1832 SvIVX(sv) = Atol(SvPVX(sv));
1836 int save_errno = errno;
1837 /* Is it an integer that we could convert with strtol?
1838 So try it, and if it doesn't set errno then it's pukka.
1839 This should be faster than going atof and then thinking. */
1840 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1841 == IS_NUMBER_TO_INT_BY_STRTOL)
1842 /* && is a sequence point. Without it not sure if I'm trying
1843 to do too much between sequence points and hence going
1845 && ((errno = 0), 1) /* , 1 so always true */
1846 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1848 if (SvTYPE(sv) < SVt_PVIV)
1849 sv_upgrade(sv, SVt_PVIV);
1858 /* Hopefully trace flow will optimise this away where possible
1862 /* It wasn't an integer, or it overflowed, or we don't have
1863 strtol. Do things the slow way - check if it's a UV etc. */
1864 d = Atof(SvPVX(sv));
1866 if (SvTYPE(sv) < SVt_PVNV)
1867 sv_upgrade(sv, SVt_PVNV);
1870 if (! numtype && ckWARN(WARN_NUMERIC))
1873 #if defined(USE_LONG_DOUBLE)
1874 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1875 PTR2UV(sv), SvNVX(sv)));
1877 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1878 PTR2UV(sv), SvNVX(sv)));
1882 #ifdef NV_PRESERVES_UV
1883 (void)SvIOKp_on(sv);
1885 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1886 SvIVX(sv) = I_V(SvNVX(sv));
1887 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1890 /* Integer is imprecise. NOK, IOKp */
1892 /* UV will not work better than IV */
1894 if (SvNVX(sv) > (NV)UV_MAX) {
1896 /* Integer is inaccurate. NOK, IOKp, is UV */
1900 SvUVX(sv) = U_V(SvNVX(sv));
1901 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1902 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1906 /* Integer is imprecise. NOK, IOKp, is UV */
1912 #else /* NV_PRESERVES_UV */
1913 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1914 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1915 /* Small enough to preserve all bits. */
1916 (void)SvIOKp_on(sv);
1918 SvIVX(sv) = I_V(SvNVX(sv));
1919 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1921 /* Assumption: first non-preserved integer is < IV_MAX,
1922 this NV is in the preserved range, therefore: */
1923 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1925 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
1927 } else if (sv_2iuv_non_preserve (sv, numtype)
1928 >= IS_NUMBER_OVERFLOW_IV)
1930 #endif /* NV_PRESERVES_UV */
1934 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1936 if (SvTYPE(sv) < SVt_IV)
1937 /* Typically the caller expects that sv_any is not NULL now. */
1938 sv_upgrade(sv, SVt_IV);
1941 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1942 PTR2UV(sv),SvIVX(sv)));
1943 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1947 Perl_sv_2uv(pTHX_ register SV *sv)
1951 if (SvGMAGICAL(sv)) {
1956 return U_V(SvNVX(sv));
1957 if (SvPOKp(sv) && SvLEN(sv))
1960 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1961 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1967 if (SvTHINKFIRST(sv)) {
1970 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1971 (SvRV(tmpstr) != SvRV(sv)))
1972 return SvUV(tmpstr);
1973 return PTR2UV(SvRV(sv));
1975 if (SvREADONLY(sv) && SvFAKE(sv)) {
1976 sv_force_normal(sv);
1978 if (SvREADONLY(sv) && !SvOK(sv)) {
1979 if (ckWARN(WARN_UNINITIALIZED))
1989 return (UV)SvIVX(sv);
1993 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1994 * without also getting a cached IV/UV from it at the same time
1995 * (ie PV->NV conversion should detect loss of accuracy and cache
1996 * IV or UV at same time to avoid this. */
1997 /* IV-over-UV optimisation - choose to cache IV if possible */
1999 if (SvTYPE(sv) == SVt_NV)
2000 sv_upgrade(sv, SVt_PVNV);
2002 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2003 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2004 SvIVX(sv) = I_V(SvNVX(sv));
2005 if (SvNVX(sv) == (NV) SvIVX(sv)
2006 #ifndef NV_PRESERVES_UV
2007 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2008 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2009 /* Don't flag it as "accurately an integer" if the number
2010 came from a (by definition imprecise) NV operation, and
2011 we're outside the range of NV integer precision */
2014 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2015 DEBUG_c(PerlIO_printf(Perl_debug_log,
2016 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2022 /* IV not precise. No need to convert from PV, as NV
2023 conversion would already have cached IV if it detected
2024 that PV->IV would be better than PV->NV->IV
2025 flags already correct - don't set public IOK. */
2026 DEBUG_c(PerlIO_printf(Perl_debug_log,
2027 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2032 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2033 but the cast (NV)IV_MIN rounds to a the value less (more
2034 negative) than IV_MIN which happens to be equal to SvNVX ??
2035 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2036 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2037 (NV)UVX == NVX are both true, but the values differ. :-(
2038 Hopefully for 2s complement IV_MIN is something like
2039 0x8000000000000000 which will be exact. NWC */
2042 SvUVX(sv) = U_V(SvNVX(sv));
2044 (SvNVX(sv) == (NV) SvUVX(sv))
2045 #ifndef NV_PRESERVES_UV
2046 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2047 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2048 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2049 /* Don't flag it as "accurately an integer" if the number
2050 came from a (by definition imprecise) NV operation, and
2051 we're outside the range of NV integer precision */
2056 DEBUG_c(PerlIO_printf(Perl_debug_log,
2057 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2063 else if (SvPOKp(sv) && SvLEN(sv)) {
2064 I32 numtype = looks_like_number(sv);
2066 /* We want to avoid a possible problem when we cache a UV which
2067 may be later translated to an NV, and the resulting NV is not
2068 the translation of the initial data.
2070 This means that if we cache such a UV, we need to cache the
2071 NV as well. Moreover, we trade speed for space, and do not
2072 cache the NV if not needed.
2075 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2076 /* The NV may be reconstructed from IV - safe to cache IV,
2077 which may be calculated by atol(). */
2078 if (SvTYPE(sv) < SVt_PVIV)
2079 sv_upgrade(sv, SVt_PVIV);
2081 SvIVX(sv) = Atol(SvPVX(sv));
2085 char *num_begin = SvPVX(sv);
2086 int save_errno = errno;
2088 /* seems that strtoul taking numbers that start with - is
2089 implementation dependant, and can't be relied upon. */
2090 if (numtype & IS_NUMBER_NEG) {
2091 /* Not totally defensive. assumine that looks_like_num
2092 didn't lie about a - sign */
2093 while (isSPACE(*num_begin))
2095 if (*num_begin == '-')
2099 /* Is it an integer that we could convert with strtoul?
2100 So try it, and if it doesn't set errno then it's pukka.
2101 This should be faster than going atof and then thinking. */
2102 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2103 == IS_NUMBER_TO_INT_BY_STRTOL)
2104 && ((errno = 0), 1) /* always true */
2105 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2107 /* If known to be negative, check it didn't undeflow IV
2108 XXX possibly we should put more negative values as NVs
2109 direct rather than go via atof below */
2110 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2113 if (SvTYPE(sv) < SVt_PVIV)
2114 sv_upgrade(sv, SVt_PVIV);
2117 /* If it's negative must use IV.
2118 IV-over-UV optimisation */
2119 if (numtype & IS_NUMBER_NEG) {
2121 } else if (u <= (UV) IV_MAX) {
2124 /* it didn't overflow, and it was positive. */
2133 /* Hopefully trace flow will optimise this away where possible
2137 /* It wasn't an integer, or it overflowed, or we don't have
2138 strtol. Do things the slow way - check if it's a IV etc. */
2139 d = Atof(SvPVX(sv));
2141 if (SvTYPE(sv) < SVt_PVNV)
2142 sv_upgrade(sv, SVt_PVNV);
2145 if (! numtype && ckWARN(WARN_NUMERIC))
2148 #if defined(USE_LONG_DOUBLE)
2149 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2150 PTR2UV(sv), SvNVX(sv)));
2152 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2153 PTR2UV(sv), SvNVX(sv)));
2156 #ifdef NV_PRESERVES_UV
2157 (void)SvIOKp_on(sv);
2159 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2160 SvIVX(sv) = I_V(SvNVX(sv));
2161 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2164 /* Integer is imprecise. NOK, IOKp */
2166 /* UV will not work better than IV */
2168 if (SvNVX(sv) > (NV)UV_MAX) {
2170 /* Integer is inaccurate. NOK, IOKp, is UV */
2174 SvUVX(sv) = U_V(SvNVX(sv));
2175 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2176 NV preservse UV so can do correct comparison. */
2177 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2181 /* Integer is imprecise. NOK, IOKp, is UV */
2186 #else /* NV_PRESERVES_UV */
2187 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2188 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2189 /* Small enough to preserve all bits. */
2190 (void)SvIOKp_on(sv);
2192 SvIVX(sv) = I_V(SvNVX(sv));
2193 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2195 /* Assumption: first non-preserved integer is < IV_MAX,
2196 this NV is in the preserved range, therefore: */
2197 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2199 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2202 sv_2iuv_non_preserve (sv, numtype);
2203 #endif /* NV_PRESERVES_UV */
2208 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2209 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2212 if (SvTYPE(sv) < SVt_IV)
2213 /* Typically the caller expects that sv_any is not NULL now. */
2214 sv_upgrade(sv, SVt_IV);
2218 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2219 PTR2UV(sv),SvUVX(sv)));
2220 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2224 Perl_sv_2nv(pTHX_ register SV *sv)
2228 if (SvGMAGICAL(sv)) {
2232 if (SvPOKp(sv) && SvLEN(sv)) {
2233 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2235 return Atof(SvPVX(sv));
2239 return (NV)SvUVX(sv);
2241 return (NV)SvIVX(sv);
2244 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2245 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2251 if (SvTHINKFIRST(sv)) {
2254 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2255 (SvRV(tmpstr) != SvRV(sv)))
2256 return SvNV(tmpstr);
2257 return PTR2NV(SvRV(sv));
2259 if (SvREADONLY(sv) && SvFAKE(sv)) {
2260 sv_force_normal(sv);
2262 if (SvREADONLY(sv) && !SvOK(sv)) {
2263 if (ckWARN(WARN_UNINITIALIZED))
2268 if (SvTYPE(sv) < SVt_NV) {
2269 if (SvTYPE(sv) == SVt_IV)
2270 sv_upgrade(sv, SVt_PVNV);
2272 sv_upgrade(sv, SVt_NV);
2273 #if defined(USE_LONG_DOUBLE)
2275 STORE_NUMERIC_LOCAL_SET_STANDARD();
2276 PerlIO_printf(Perl_debug_log,
2277 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2278 PTR2UV(sv), SvNVX(sv));
2279 RESTORE_NUMERIC_LOCAL();
2283 STORE_NUMERIC_LOCAL_SET_STANDARD();
2284 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2285 PTR2UV(sv), SvNVX(sv));
2286 RESTORE_NUMERIC_LOCAL();
2290 else if (SvTYPE(sv) < SVt_PVNV)
2291 sv_upgrade(sv, SVt_PVNV);
2293 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2295 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2296 #ifdef NV_PRESERVES_UV
2299 /* Only set the public NV OK flag if this NV preserves the IV */
2300 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2301 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2302 : (SvIVX(sv) == I_V(SvNVX(sv))))
2308 else if (SvPOKp(sv) && SvLEN(sv)) {
2309 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2311 SvNVX(sv) = Atof(SvPVX(sv));
2312 #ifdef NV_PRESERVES_UV
2315 /* Only set the public NV OK flag if this NV preserves the value in
2316 the PV at least as well as an IV/UV would.
2317 Not sure how to do this 100% reliably. */
2318 /* if that shift count is out of range then Configure's test is
2319 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2321 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2322 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2323 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2324 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2325 /* Definitely too large/small to fit in an integer, so no loss
2326 of precision going to integer in the future via NV */
2329 /* Is it something we can run through strtol etc (ie no
2330 trailing exponent part)? */
2331 int numtype = looks_like_number(sv);
2332 /* XXX probably should cache this if called above */
2335 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2336 /* Can't use strtol etc to convert this string, so don't try */
2339 sv_2inuv_non_preserve (sv, numtype);
2341 #endif /* NV_PRESERVES_UV */
2344 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2346 if (SvTYPE(sv) < SVt_NV)
2347 /* Typically the caller expects that sv_any is not NULL now. */
2348 /* XXX Ilya implies that this is a bug in callers that assume this
2349 and ideally should be fixed. */
2350 sv_upgrade(sv, SVt_NV);
2353 #if defined(USE_LONG_DOUBLE)
2355 STORE_NUMERIC_LOCAL_SET_STANDARD();
2356 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2357 PTR2UV(sv), SvNVX(sv));
2358 RESTORE_NUMERIC_LOCAL();
2362 STORE_NUMERIC_LOCAL_SET_STANDARD();
2363 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2364 PTR2UV(sv), SvNVX(sv));
2365 RESTORE_NUMERIC_LOCAL();
2372 S_asIV(pTHX_ SV *sv)
2374 I32 numtype = looks_like_number(sv);
2377 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2378 return Atol(SvPVX(sv));
2380 if (ckWARN(WARN_NUMERIC))
2383 d = Atof(SvPVX(sv));
2388 S_asUV(pTHX_ SV *sv)
2390 I32 numtype = looks_like_number(sv);
2393 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2394 return Strtoul(SvPVX(sv), Null(char**), 10);
2397 if (ckWARN(WARN_NUMERIC))
2400 return U_V(Atof(SvPVX(sv)));
2404 * Returns a combination of (advisory only - can get false negatives)
2405 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2406 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2407 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2408 * 0 if does not look like number.
2410 * (atol and strtol stop when they hit a decimal point. strtol will return
2411 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2412 * do this, and vendors have had 11 years to get it right.
2413 * However, will try to make it still work with only atol
2415 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2416 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2417 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2418 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2419 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2420 * IS_NUMBER_NOT_INT saw "." or "e"
2422 * IS_NUMBER_INFINITY
2426 =for apidoc looks_like_number
2428 Test if an the content of an SV looks like a number (or is a
2429 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2430 issue a non-numeric warning), even if your atof() doesn't grok them.
2436 Perl_looks_like_number(pTHX_ SV *sv)
2439 register char *send;
2440 register char *sbegin;
2441 register char *nbegin;
2450 else if (SvPOKp(sv))
2451 sbegin = SvPV(sv, len);
2454 send = sbegin + len;
2461 numtype = IS_NUMBER_NEG;
2468 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2469 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2470 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2471 * will need (int)atof().
2474 /* next must be digit or the radix separator or beginning of infinity */
2478 } while (isDIGIT(*s));
2480 /* Aaargh. long long really is irritating.
2481 In the gospel according to ANSI 1989, it is an axiom that "long"
2482 is the longest integer type, and that if you don't know how long
2483 something is you can cast it to long, and nothing will be lost
2484 (except possibly speed of execution if long is slower than the
2486 Now, one can't be sure if the old rules apply, or long long
2487 (or some other newfangled thing) is actually longer than the
2488 (formerly) longest thing.
2490 /* This lot will work for 64 bit *as long as* either
2491 either long is 64 bit
2492 or we can find both strtol/strtoq and strtoul/strtouq
2493 If not, we really should refuse to let the user use 64 bit IVs
2494 By "64 bit" I really mean IVs that don't get preserved by NVs
2495 It also should work for 128 bit IVs. Can any lend me a machine to
2498 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2499 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2500 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2501 ? sizeof(long) : sizeof (IV))*8-1))
2502 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2504 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2505 digit less (IV_MAX= 9223372036854775807,
2506 UV_MAX= 18446744073709551615) so be cautious */
2507 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2510 #ifdef USE_LOCALE_NUMERIC
2511 || IS_NUMERIC_RADIX(*s)
2515 numtype |= IS_NUMBER_NOT_INT;
2516 while (isDIGIT(*s)) /* optional digits after the radix */
2521 #ifdef USE_LOCALE_NUMERIC
2522 || IS_NUMERIC_RADIX(*s)
2526 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2527 /* no digits before the radix means we need digits after it */
2531 } while (isDIGIT(*s));
2536 else if (*s == 'I' || *s == 'i') {
2537 s++; if (*s != 'N' && *s != 'n') return 0;
2538 s++; if (*s != 'F' && *s != 'f') return 0;
2539 s++; if (*s == 'I' || *s == 'i') {
2540 s++; if (*s != 'N' && *s != 'n') return 0;
2541 s++; if (*s != 'I' && *s != 'i') return 0;
2542 s++; if (*s != 'T' && *s != 't') return 0;
2543 s++; if (*s != 'Y' && *s != 'y') return 0;
2552 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2553 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2555 /* we can have an optional exponent part */
2556 if (*s == 'e' || *s == 'E') {
2557 numtype &= IS_NUMBER_NEG;
2558 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2560 if (*s == '+' || *s == '-')
2565 } while (isDIGIT(*s));
2575 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2576 return IS_NUMBER_TO_INT_BY_ATOL;
2581 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2584 return sv_2pv(sv, &n_a);
2587 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2589 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2591 char *ptr = buf + TYPE_CHARS(UV);
2605 *--ptr = '0' + (uv % 10);
2614 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2619 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2620 char *tmpbuf = tbuf;
2626 if (SvGMAGICAL(sv)) {
2634 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2636 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2641 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2646 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2647 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2654 if (SvTHINKFIRST(sv)) {
2657 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2658 (SvRV(tmpstr) != SvRV(sv)))
2659 return SvPV(tmpstr,*lp);
2666 switch (SvTYPE(sv)) {
2668 if ( ((SvFLAGS(sv) &
2669 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2670 == (SVs_OBJECT|SVs_RMG))
2671 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2672 && (mg = mg_find(sv, 'r'))) {
2673 regexp *re = (regexp *)mg->mg_obj;
2676 char *fptr = "msix";
2681 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2683 while((ch = *fptr++)) {
2685 reflags[left++] = ch;
2688 reflags[right--] = ch;
2693 reflags[left] = '-';
2697 mg->mg_len = re->prelen + 4 + left;
2698 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2699 Copy("(?", mg->mg_ptr, 2, char);
2700 Copy(reflags, mg->mg_ptr+2, left, char);
2701 Copy(":", mg->mg_ptr+left+2, 1, char);
2702 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2703 mg->mg_ptr[mg->mg_len - 1] = ')';
2704 mg->mg_ptr[mg->mg_len] = 0;
2706 PL_reginterp_cnt += re->program[0].next_off;
2718 case SVt_PVBM: if (SvROK(sv))
2721 s = "SCALAR"; break;
2722 case SVt_PVLV: s = "LVALUE"; break;
2723 case SVt_PVAV: s = "ARRAY"; break;
2724 case SVt_PVHV: s = "HASH"; break;
2725 case SVt_PVCV: s = "CODE"; break;
2726 case SVt_PVGV: s = "GLOB"; break;
2727 case SVt_PVFM: s = "FORMAT"; break;
2728 case SVt_PVIO: s = "IO"; break;
2729 default: s = "UNKNOWN"; break;
2733 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2736 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2742 if (SvREADONLY(sv) && !SvOK(sv)) {
2743 if (ckWARN(WARN_UNINITIALIZED))
2749 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2750 /* I'm assuming that if both IV and NV are equally valid then
2751 converting the IV is going to be more efficient */
2752 U32 isIOK = SvIOK(sv);
2753 U32 isUIOK = SvIsUV(sv);
2754 char buf[TYPE_CHARS(UV)];
2757 if (SvTYPE(sv) < SVt_PVIV)
2758 sv_upgrade(sv, SVt_PVIV);
2760 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2762 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2763 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2764 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2765 SvCUR_set(sv, ebuf - ptr);
2775 else if (SvNOKp(sv)) {
2776 if (SvTYPE(sv) < SVt_PVNV)
2777 sv_upgrade(sv, SVt_PVNV);
2778 /* The +20 is pure guesswork. Configure test needed. --jhi */
2779 SvGROW(sv, NV_DIG + 20);
2781 olderrno = errno; /* some Xenix systems wipe out errno here */
2783 if (SvNVX(sv) == 0.0)
2784 (void)strcpy(s,"0");
2788 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2791 #ifdef FIXNEGATIVEZERO
2792 if (*s == '-' && s[1] == '0' && !s[2])
2802 if (ckWARN(WARN_UNINITIALIZED)
2803 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2806 if (SvTYPE(sv) < SVt_PV)
2807 /* Typically the caller expects that sv_any is not NULL now. */
2808 sv_upgrade(sv, SVt_PV);
2811 *lp = s - SvPVX(sv);
2814 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2815 PTR2UV(sv),SvPVX(sv)));
2819 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2820 /* Sneaky stuff here */
2824 tsv = newSVpv(tmpbuf, 0);
2840 len = strlen(tmpbuf);
2842 #ifdef FIXNEGATIVEZERO
2843 if (len == 2 && t[0] == '-' && t[1] == '0') {
2848 (void)SvUPGRADE(sv, SVt_PV);
2850 s = SvGROW(sv, len + 1);
2859 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2862 return sv_2pvbyte(sv, &n_a);
2866 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2868 return sv_2pv(sv,lp);
2872 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2875 return sv_2pvutf8(sv, &n_a);
2879 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2881 sv_utf8_upgrade(sv);
2882 return SvPV(sv,*lp);
2885 /* This function is only called on magical items */
2887 Perl_sv_2bool(pTHX_ register SV *sv)
2896 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2897 (SvRV(tmpsv) != SvRV(sv)))
2898 return SvTRUE(tmpsv);
2899 return SvRV(sv) != 0;
2902 register XPV* Xpvtmp;
2903 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2904 (*Xpvtmp->xpv_pv > '0' ||
2905 Xpvtmp->xpv_cur > 1 ||
2906 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2913 return SvIVX(sv) != 0;
2916 return SvNVX(sv) != 0.0;
2924 =for apidoc sv_utf8_upgrade
2926 Convert the PV of an SV to its UTF8-encoded form.
2932 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2937 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2940 /* This function could be much more efficient if we had a FLAG in SVs
2941 * to signal if there are any hibit chars in the PV.
2942 * Given that there isn't make loop fast as possible
2948 if ((hibit = *t++ & 0x80))
2954 if (SvREADONLY(sv) && SvFAKE(sv)) {
2955 sv_force_normal(sv);
2958 len = SvCUR(sv) + 1; /* Plus the \0 */
2959 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2960 SvCUR(sv) = len - 1;
2962 Safefree(s); /* No longer using what was there before. */
2963 SvLEN(sv) = len; /* No longer know the real size. */
2969 =for apidoc sv_utf8_downgrade
2971 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2972 This may not be possible if the PV contains non-byte encoding characters;
2973 if this is the case, either returns false or, if C<fail_ok> is not
2980 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2982 if (SvPOK(sv) && SvUTF8(sv)) {
2984 char *c = SvPVX(sv);
2985 STRLEN len = SvCUR(sv);
2987 if (!utf8_to_bytes((U8*)c, &len)) {
2992 Perl_croak(aTHX_ "Wide character in %s",
2993 PL_op_desc[PL_op->op_type]);
2995 Perl_croak(aTHX_ "Wide character");
3007 =for apidoc sv_utf8_encode
3009 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3010 flag so that it looks like bytes again. Nothing calls this.
3016 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3018 sv_utf8_upgrade(sv);
3023 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3028 bool has_utf = FALSE;
3029 if (!sv_utf8_downgrade(sv, TRUE))
3032 /* it is actually just a matter of turning the utf8 flag on, but
3033 * we want to make sure everything inside is valid utf8 first.
3036 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
3050 /* Note: sv_setsv() should not be called with a source string that needs
3051 * to be reused, since it may destroy the source string if it is marked
3056 =for apidoc sv_setsv
3058 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3059 The source SV may be destroyed if it is mortal. Does not handle 'set'
3060 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3067 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3069 register U32 sflags;
3075 SV_CHECK_THINKFIRST(dstr);
3077 sstr = &PL_sv_undef;
3078 stype = SvTYPE(sstr);
3079 dtype = SvTYPE(dstr);
3083 /* There's a lot of redundancy below but we're going for speed here */
3088 if (dtype != SVt_PVGV) {
3089 (void)SvOK_off(dstr);
3097 sv_upgrade(dstr, SVt_IV);
3100 sv_upgrade(dstr, SVt_PVNV);
3104 sv_upgrade(dstr, SVt_PVIV);
3107 (void)SvIOK_only(dstr);
3108 SvIVX(dstr) = SvIVX(sstr);
3111 if (SvTAINTED(sstr))
3122 sv_upgrade(dstr, SVt_NV);
3127 sv_upgrade(dstr, SVt_PVNV);
3130 SvNVX(dstr) = SvNVX(sstr);
3131 (void)SvNOK_only(dstr);
3132 if (SvTAINTED(sstr))
3140 sv_upgrade(dstr, SVt_RV);
3141 else if (dtype == SVt_PVGV &&
3142 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3145 if (GvIMPORTED(dstr) != GVf_IMPORTED
3146 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3148 GvIMPORTED_on(dstr);
3159 sv_upgrade(dstr, SVt_PV);
3162 if (dtype < SVt_PVIV)
3163 sv_upgrade(dstr, SVt_PVIV);
3166 if (dtype < SVt_PVNV)
3167 sv_upgrade(dstr, SVt_PVNV);
3174 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3175 PL_op_name[PL_op->op_type]);
3177 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3181 if (dtype <= SVt_PVGV) {
3183 if (dtype != SVt_PVGV) {
3184 char *name = GvNAME(sstr);
3185 STRLEN len = GvNAMELEN(sstr);
3186 sv_upgrade(dstr, SVt_PVGV);
3187 sv_magic(dstr, dstr, '*', Nullch, 0);
3188 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3189 GvNAME(dstr) = savepvn(name, len);
3190 GvNAMELEN(dstr) = len;
3191 SvFAKE_on(dstr); /* can coerce to non-glob */
3193 /* ahem, death to those who redefine active sort subs */
3194 else if (PL_curstackinfo->si_type == PERLSI_SORT
3195 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3196 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3198 (void)SvOK_off(dstr);
3199 GvINTRO_off(dstr); /* one-shot flag */
3201 GvGP(dstr) = gp_ref(GvGP(sstr));
3202 if (SvTAINTED(sstr))
3204 if (GvIMPORTED(dstr) != GVf_IMPORTED
3205 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3207 GvIMPORTED_on(dstr);
3215 if (SvGMAGICAL(sstr)) {
3217 if (SvTYPE(sstr) != stype) {
3218 stype = SvTYPE(sstr);
3219 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3223 if (stype == SVt_PVLV)
3224 (void)SvUPGRADE(dstr, SVt_PVNV);
3226 (void)SvUPGRADE(dstr, stype);
3229 sflags = SvFLAGS(sstr);
3231 if (sflags & SVf_ROK) {
3232 if (dtype >= SVt_PV) {
3233 if (dtype == SVt_PVGV) {
3234 SV *sref = SvREFCNT_inc(SvRV(sstr));
3236 int intro = GvINTRO(dstr);
3241 GvINTRO_off(dstr); /* one-shot flag */
3242 Newz(602,gp, 1, GP);
3243 GvGP(dstr) = gp_ref(gp);
3244 GvSV(dstr) = NEWSV(72,0);
3245 GvLINE(dstr) = CopLINE(PL_curcop);
3246 GvEGV(dstr) = (GV*)dstr;
3249 switch (SvTYPE(sref)) {
3252 SAVESPTR(GvAV(dstr));
3254 dref = (SV*)GvAV(dstr);
3255 GvAV(dstr) = (AV*)sref;
3256 if (!GvIMPORTED_AV(dstr)
3257 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3259 GvIMPORTED_AV_on(dstr);
3264 SAVESPTR(GvHV(dstr));
3266 dref = (SV*)GvHV(dstr);
3267 GvHV(dstr) = (HV*)sref;
3268 if (!GvIMPORTED_HV(dstr)
3269 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3271 GvIMPORTED_HV_on(dstr);
3276 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3277 SvREFCNT_dec(GvCV(dstr));
3278 GvCV(dstr) = Nullcv;
3279 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280 PL_sub_generation++;
3282 SAVESPTR(GvCV(dstr));
3285 dref = (SV*)GvCV(dstr);
3286 if (GvCV(dstr) != (CV*)sref) {
3287 CV* cv = GvCV(dstr);
3289 if (!GvCVGEN((GV*)dstr) &&
3290 (CvROOT(cv) || CvXSUB(cv)))
3293 /* ahem, death to those who redefine
3294 * active sort subs */
3295 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3296 PL_sortcop == CvSTART(cv))
3298 "Can't redefine active sort subroutine %s",
3299 GvENAME((GV*)dstr));
3300 /* Redefining a sub - warning is mandatory if
3301 it was a const and its value changed. */
3302 if (ckWARN(WARN_REDEFINE)
3304 && (!CvCONST((CV*)sref)
3305 || sv_cmp(cv_const_sv(cv),
3306 cv_const_sv((CV*)sref)))))
3308 Perl_warner(aTHX_ WARN_REDEFINE,
3310 ? "Constant subroutine %s redefined"
3311 : "Subroutine %s redefined",
3312 GvENAME((GV*)dstr));
3315 cv_ckproto(cv, (GV*)dstr,
3316 SvPOK(sref) ? SvPVX(sref) : Nullch);
3318 GvCV(dstr) = (CV*)sref;
3319 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3320 GvASSUMECV_on(dstr);
3321 PL_sub_generation++;
3323 if (!GvIMPORTED_CV(dstr)
3324 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3326 GvIMPORTED_CV_on(dstr);
3331 SAVESPTR(GvIOp(dstr));
3333 dref = (SV*)GvIOp(dstr);
3334 GvIOp(dstr) = (IO*)sref;
3338 SAVESPTR(GvFORM(dstr));
3340 dref = (SV*)GvFORM(dstr);
3341 GvFORM(dstr) = (CV*)sref;
3345 SAVESPTR(GvSV(dstr));
3347 dref = (SV*)GvSV(dstr);
3349 if (!GvIMPORTED_SV(dstr)
3350 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3352 GvIMPORTED_SV_on(dstr);
3360 if (SvTAINTED(sstr))
3365 (void)SvOOK_off(dstr); /* backoff */
3367 Safefree(SvPVX(dstr));
3368 SvLEN(dstr)=SvCUR(dstr)=0;
3371 (void)SvOK_off(dstr);
3372 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3374 if (sflags & SVp_NOK) {
3376 SvNVX(dstr) = SvNVX(sstr);
3378 if (sflags & SVp_IOK) {
3379 (void)SvIOK_on(dstr);
3380 SvIVX(dstr) = SvIVX(sstr);
3381 if (sflags & SVf_IVisUV)
3384 if (SvAMAGIC(sstr)) {
3388 else if (sflags & SVp_POK) {
3391 * Check to see if we can just swipe the string. If so, it's a
3392 * possible small lose on short strings, but a big win on long ones.
3393 * It might even be a win on short strings if SvPVX(dstr)
3394 * has to be allocated and SvPVX(sstr) has to be freed.
3397 if (SvTEMP(sstr) && /* slated for free anyway? */
3398 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3399 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3400 SvLEN(sstr) && /* and really is a string */
3401 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3403 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3405 SvFLAGS(dstr) &= ~SVf_OOK;
3406 Safefree(SvPVX(dstr) - SvIVX(dstr));
3408 else if (SvLEN(dstr))
3409 Safefree(SvPVX(dstr));
3411 (void)SvPOK_only(dstr);
3412 SvPV_set(dstr, SvPVX(sstr));
3413 SvLEN_set(dstr, SvLEN(sstr));
3414 SvCUR_set(dstr, SvCUR(sstr));
3417 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3418 SvPV_set(sstr, Nullch);
3423 else { /* have to copy actual string */
3424 STRLEN len = SvCUR(sstr);
3426 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3427 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3428 SvCUR_set(dstr, len);
3429 *SvEND(dstr) = '\0';
3430 (void)SvPOK_only(dstr);
3432 if ((sflags & SVf_UTF8) && !IN_BYTE)
3435 if (sflags & SVp_NOK) {
3437 SvNVX(dstr) = SvNVX(sstr);
3439 if (sflags & SVp_IOK) {
3440 (void)SvIOK_on(dstr);
3441 SvIVX(dstr) = SvIVX(sstr);
3442 if (sflags & SVf_IVisUV)
3446 else if (sflags & SVp_NOK) {
3447 SvNVX(dstr) = SvNVX(sstr);
3448 (void)SvNOK_only(dstr);
3449 if (sflags & SVf_IOK) {
3450 (void)SvIOK_on(dstr);
3451 SvIVX(dstr) = SvIVX(sstr);
3452 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3453 if (sflags & SVf_IVisUV)
3457 else if (sflags & SVp_IOK) {
3458 (void)SvIOK_only(dstr);
3459 SvIVX(dstr) = SvIVX(sstr);
3460 if (sflags & SVf_IVisUV)
3464 if (dtype == SVt_PVGV) {
3465 if (ckWARN(WARN_MISC))
3466 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3469 (void)SvOK_off(dstr);
3471 if (SvTAINTED(sstr))
3476 =for apidoc sv_setsv_mg
3478 Like C<sv_setsv>, but also handles 'set' magic.
3484 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3486 sv_setsv(dstr,sstr);
3491 =for apidoc sv_setpvn
3493 Copies a string into an SV. The C<len> parameter indicates the number of
3494 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3500 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3502 register char *dptr;
3504 /* len is STRLEN which is unsigned, need to copy to signed */
3508 SV_CHECK_THINKFIRST(sv);
3513 (void)SvUPGRADE(sv, SVt_PV);
3515 SvGROW(sv, len + 1);
3517 Move(ptr,dptr,len,char);
3520 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3525 =for apidoc sv_setpvn_mg
3527 Like C<sv_setpvn>, but also handles 'set' magic.
3533 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3535 sv_setpvn(sv,ptr,len);
3540 =for apidoc sv_setpv
3542 Copies a string into an SV. The string must be null-terminated. Does not
3543 handle 'set' magic. See C<sv_setpv_mg>.
3549 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3551 register STRLEN len;
3553 SV_CHECK_THINKFIRST(sv);
3559 (void)SvUPGRADE(sv, SVt_PV);
3561 SvGROW(sv, len + 1);
3562 Move(ptr,SvPVX(sv),len+1,char);
3564 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3569 =for apidoc sv_setpv_mg
3571 Like C<sv_setpv>, but also handles 'set' magic.
3577 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3584 =for apidoc sv_usepvn
3586 Tells an SV to use C<ptr> to find its string value. Normally the string is
3587 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3588 The C<ptr> should point to memory that was allocated by C<malloc>. The
3589 string length, C<len>, must be supplied. This function will realloc the
3590 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3591 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3592 See C<sv_usepvn_mg>.
3598 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3600 SV_CHECK_THINKFIRST(sv);
3601 (void)SvUPGRADE(sv, SVt_PV);
3606 (void)SvOOK_off(sv);
3607 if (SvPVX(sv) && SvLEN(sv))
3608 Safefree(SvPVX(sv));
3609 Renew(ptr, len+1, char);
3612 SvLEN_set(sv, len+1);
3614 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3619 =for apidoc sv_usepvn_mg
3621 Like C<sv_usepvn>, but also handles 'set' magic.
3627 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3629 sv_usepvn(sv,ptr,len);
3634 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3636 if (SvREADONLY(sv)) {
3638 char *pvx = SvPVX(sv);
3639 STRLEN len = SvCUR(sv);
3640 U32 hash = SvUVX(sv);
3641 SvGROW(sv, len + 1);
3642 Move(pvx,SvPVX(sv),len,char);
3646 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3648 else if (PL_curcop != &PL_compiling)
3649 Perl_croak(aTHX_ PL_no_modify);
3652 sv_unref_flags(sv, flags);
3653 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3658 Perl_sv_force_normal(pTHX_ register SV *sv)
3660 sv_force_normal_flags(sv, 0);
3666 Efficient removal of characters from the beginning of the string buffer.
3667 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3668 the string buffer. The C<ptr> becomes the first character of the adjusted
3675 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3679 register STRLEN delta;
3681 if (!ptr || !SvPOKp(sv))
3683 SV_CHECK_THINKFIRST(sv);
3684 if (SvTYPE(sv) < SVt_PVIV)
3685 sv_upgrade(sv,SVt_PVIV);
3688 if (!SvLEN(sv)) { /* make copy of shared string */
3689 char *pvx = SvPVX(sv);
3690 STRLEN len = SvCUR(sv);
3691 SvGROW(sv, len + 1);
3692 Move(pvx,SvPVX(sv),len,char);
3696 SvFLAGS(sv) |= SVf_OOK;
3698 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3699 delta = ptr - SvPVX(sv);
3707 =for apidoc sv_catpvn
3709 Concatenates the string onto the end of the string which is in the SV. The
3710 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3711 'set' magic. See C<sv_catpvn_mg>.
3717 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3722 junk = SvPV_force(sv, tlen);
3723 SvGROW(sv, tlen + len + 1);
3726 Move(ptr,SvPVX(sv)+tlen,len,char);
3729 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3734 =for apidoc sv_catpvn_mg
3736 Like C<sv_catpvn>, but also handles 'set' magic.
3742 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3744 sv_catpvn(sv,ptr,len);
3749 =for apidoc sv_catsv
3751 Concatenates the string from SV C<ssv> onto the end of the string in
3752 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3753 not 'set' magic. See C<sv_catsv_mg>.
3758 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3764 if ((spv = SvPV(ssv, slen))) {
3765 bool dutf8 = DO_UTF8(dsv);
3766 bool sutf8 = DO_UTF8(ssv);
3769 sv_catpvn(dsv,spv,slen);
3772 /* Not modifying source SV, so taking a temporary copy. */
3773 SV* csv = sv_2mortal(newSVsv(ssv));
3777 sv_utf8_upgrade(csv);
3778 cpv = SvPV(csv,clen);
3779 sv_catpvn(dsv,cpv,clen);
3782 sv_utf8_upgrade(dsv);
3783 sv_catpvn(dsv,spv,slen);
3784 SvUTF8_on(dsv); /* If dsv has no wide characters. */
3791 =for apidoc sv_catsv_mg
3793 Like C<sv_catsv>, but also handles 'set' magic.
3799 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3806 =for apidoc sv_catpv
3808 Concatenates the string onto the end of the string which is in the SV.
3809 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3815 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3817 register STRLEN len;
3823 junk = SvPV_force(sv, tlen);
3825 SvGROW(sv, tlen + len + 1);
3828 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3830 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3835 =for apidoc sv_catpv_mg
3837 Like C<sv_catpv>, but also handles 'set' magic.
3843 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3850 Perl_newSV(pTHX_ STRLEN len)
3856 sv_upgrade(sv, SVt_PV);
3857 SvGROW(sv, len + 1);
3862 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3865 =for apidoc sv_magic
3867 Adds magic to an SV.
3873 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3877 if (SvREADONLY(sv)) {
3878 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3879 Perl_croak(aTHX_ PL_no_modify);
3881 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3882 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3889 (void)SvUPGRADE(sv, SVt_PVMG);
3891 Newz(702,mg, 1, MAGIC);
3892 mg->mg_moremagic = SvMAGIC(sv);
3895 if (!obj || obj == sv || how == '#' || how == 'r')
3898 mg->mg_obj = SvREFCNT_inc(obj);
3899 mg->mg_flags |= MGf_REFCOUNTED;
3902 mg->mg_len = namlen;
3905 mg->mg_ptr = savepvn(name, namlen);
3906 else if (namlen == HEf_SVKEY)
3907 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3911 mg->mg_virtual = &PL_vtbl_sv;
3914 mg->mg_virtual = &PL_vtbl_amagic;
3917 mg->mg_virtual = &PL_vtbl_amagicelem;
3923 mg->mg_virtual = &PL_vtbl_bm;
3926 mg->mg_virtual = &PL_vtbl_regdata;
3929 mg->mg_virtual = &PL_vtbl_regdatum;
3932 mg->mg_virtual = &PL_vtbl_env;
3935 mg->mg_virtual = &PL_vtbl_fm;
3938 mg->mg_virtual = &PL_vtbl_envelem;
3941 mg->mg_virtual = &PL_vtbl_mglob;
3944 mg->mg_virtual = &PL_vtbl_isa;
3947 mg->mg_virtual = &PL_vtbl_isaelem;
3950 mg->mg_virtual = &PL_vtbl_nkeys;
3957 mg->mg_virtual = &PL_vtbl_dbline;
3961 mg->mg_virtual = &PL_vtbl_mutex;
3963 #endif /* USE_THREADS */
3964 #ifdef USE_LOCALE_COLLATE
3966 mg->mg_virtual = &PL_vtbl_collxfrm;
3968 #endif /* USE_LOCALE_COLLATE */
3970 mg->mg_virtual = &PL_vtbl_pack;
3974 mg->mg_virtual = &PL_vtbl_packelem;
3977 mg->mg_virtual = &PL_vtbl_regexp;
3980 mg->mg_virtual = &PL_vtbl_sig;
3983 mg->mg_virtual = &PL_vtbl_sigelem;
3986 mg->mg_virtual = &PL_vtbl_taint;
3990 mg->mg_virtual = &PL_vtbl_uvar;
3993 mg->mg_virtual = &PL_vtbl_vec;
3996 mg->mg_virtual = &PL_vtbl_substr;
3999 mg->mg_virtual = &PL_vtbl_defelem;
4002 mg->mg_virtual = &PL_vtbl_glob;
4005 mg->mg_virtual = &PL_vtbl_arylen;
4008 mg->mg_virtual = &PL_vtbl_pos;
4011 mg->mg_virtual = &PL_vtbl_backref;
4013 case '~': /* Reserved for use by extensions not perl internals. */
4014 /* Useful for attaching extension internal data to perl vars. */
4015 /* Note that multiple extensions may clash if magical scalars */
4016 /* etc holding private data from one are passed to another. */
4020 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4024 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4028 =for apidoc sv_unmagic
4030 Removes magic from an SV.
4036 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4040 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4043 for (mg = *mgp; mg; mg = *mgp) {
4044 if (mg->mg_type == type) {
4045 MGVTBL* vtbl = mg->mg_virtual;
4046 *mgp = mg->mg_moremagic;
4047 if (vtbl && vtbl->svt_free)
4048 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4049 if (mg->mg_ptr && mg->mg_type != 'g')
4050 if (mg->mg_len >= 0)
4051 Safefree(mg->mg_ptr);
4052 else if (mg->mg_len == HEf_SVKEY)
4053 SvREFCNT_dec((SV*)mg->mg_ptr);
4054 if (mg->mg_flags & MGf_REFCOUNTED)
4055 SvREFCNT_dec(mg->mg_obj);
4059 mgp = &mg->mg_moremagic;
4063 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4070 =for apidoc sv_rvweaken
4078 Perl_sv_rvweaken(pTHX_ SV *sv)
4081 if (!SvOK(sv)) /* let undefs pass */
4084 Perl_croak(aTHX_ "Can't weaken a nonreference");
4085 else if (SvWEAKREF(sv)) {
4086 if (ckWARN(WARN_MISC))
4087 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4091 sv_add_backref(tsv, sv);
4098 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4102 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4103 av = (AV*)mg->mg_obj;
4106 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4107 SvREFCNT_dec(av); /* for sv_magic */
4113 S_sv_del_backref(pTHX_ SV *sv)
4120 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4121 Perl_croak(aTHX_ "panic: del_backref");
4122 av = (AV *)mg->mg_obj;
4127 svp[i] = &PL_sv_undef; /* XXX */
4134 =for apidoc sv_insert
4136 Inserts a string at the specified offset/length within the SV. Similar to
4137 the Perl substr() function.
4143 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4147 register char *midend;
4148 register char *bigend;
4154 Perl_croak(aTHX_ "Can't modify non-existent substring");
4155 SvPV_force(bigstr, curlen);
4156 (void)SvPOK_only_UTF8(bigstr);
4157 if (offset + len > curlen) {
4158 SvGROW(bigstr, offset+len+1);
4159 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4160 SvCUR_set(bigstr, offset+len);
4164 i = littlelen - len;
4165 if (i > 0) { /* string might grow */
4166 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4167 mid = big + offset + len;
4168 midend = bigend = big + SvCUR(bigstr);
4171 while (midend > mid) /* shove everything down */
4172 *--bigend = *--midend;
4173 Move(little,big+offset,littlelen,char);
4179 Move(little,SvPVX(bigstr)+offset,len,char);
4184 big = SvPVX(bigstr);
4187 bigend = big + SvCUR(bigstr);
4189 if (midend > bigend)
4190 Perl_croak(aTHX_ "panic: sv_insert");
4192 if (mid - big > bigend - midend) { /* faster to shorten from end */
4194 Move(little, mid, littlelen,char);
4197 i = bigend - midend;
4199 Move(midend, mid, i,char);
4203 SvCUR_set(bigstr, mid - big);
4206 else if ((i = mid - big)) { /* faster from front */
4207 midend -= littlelen;
4209 sv_chop(bigstr,midend-i);
4214 Move(little, mid, littlelen,char);
4216 else if (littlelen) {
4217 midend -= littlelen;
4218 sv_chop(bigstr,midend);
4219 Move(little,midend,littlelen,char);
4222 sv_chop(bigstr,midend);
4228 =for apidoc sv_replace
4230 Make the first argument a copy of the second, then delete the original.
4236 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4238 U32 refcnt = SvREFCNT(sv);
4239 SV_CHECK_THINKFIRST(sv);
4240 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4241 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4242 if (SvMAGICAL(sv)) {
4246 sv_upgrade(nsv, SVt_PVMG);
4247 SvMAGIC(nsv) = SvMAGIC(sv);
4248 SvFLAGS(nsv) |= SvMAGICAL(sv);
4254 assert(!SvREFCNT(sv));
4255 StructCopy(nsv,sv,SV);
4256 SvREFCNT(sv) = refcnt;
4257 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4262 =for apidoc sv_clear
4264 Clear an SV, making it empty. Does not free the memory used by the SV
4271 Perl_sv_clear(pTHX_ register SV *sv)
4275 assert(SvREFCNT(sv) == 0);
4278 if (PL_defstash) { /* Still have a symbol table? */
4283 Zero(&tmpref, 1, SV);
4284 sv_upgrade(&tmpref, SVt_RV);
4286 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4287 SvREFCNT(&tmpref) = 1;
4290 stash = SvSTASH(sv);
4291 destructor = StashHANDLER(stash,DESTROY);
4294 PUSHSTACKi(PERLSI_DESTROY);
4295 SvRV(&tmpref) = SvREFCNT_inc(sv);
4300 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4306 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4308 del_XRV(SvANY(&tmpref));
4311 if (PL_in_clean_objs)
4312 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4314 /* DESTROY gave object new lease on life */
4320 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4321 SvOBJECT_off(sv); /* Curse the object. */
4322 if (SvTYPE(sv) != SVt_PVIO)
4323 --PL_sv_objcount; /* XXX Might want something more general */
4326 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4329 switch (SvTYPE(sv)) {
4332 IoIFP(sv) != PerlIO_stdin() &&
4333 IoIFP(sv) != PerlIO_stdout() &&
4334 IoIFP(sv) != PerlIO_stderr())
4336 io_close((IO*)sv, FALSE);
4338 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4339 PerlDir_close(IoDIRP(sv));
4340 IoDIRP(sv) = (DIR*)NULL;
4341 Safefree(IoTOP_NAME(sv));
4342 Safefree(IoFMT_NAME(sv));
4343 Safefree(IoBOTTOM_NAME(sv));
4358 SvREFCNT_dec(LvTARG(sv));
4362 Safefree(GvNAME(sv));
4363 /* cannot decrease stash refcount yet, as we might recursively delete
4364 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4365 of stash until current sv is completely gone.
4366 -- JohnPC, 27 Mar 1998 */
4367 stash = GvSTASH(sv);
4373 (void)SvOOK_off(sv);
4381 SvREFCNT_dec(SvRV(sv));
4383 else if (SvPVX(sv) && SvLEN(sv))
4384 Safefree(SvPVX(sv));
4385 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4386 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4398 switch (SvTYPE(sv)) {
4414 del_XPVIV(SvANY(sv));
4417 del_XPVNV(SvANY(sv));
4420 del_XPVMG(SvANY(sv));
4423 del_XPVLV(SvANY(sv));
4426 del_XPVAV(SvANY(sv));
4429 del_XPVHV(SvANY(sv));
4432 del_XPVCV(SvANY(sv));
4435 del_XPVGV(SvANY(sv));
4436 /* code duplication for increased performance. */
4437 SvFLAGS(sv) &= SVf_BREAK;
4438 SvFLAGS(sv) |= SVTYPEMASK;
4439 /* decrease refcount of the stash that owns this GV, if any */
4441 SvREFCNT_dec(stash);
4442 return; /* not break, SvFLAGS reset already happened */
4444 del_XPVBM(SvANY(sv));
4447 del_XPVFM(SvANY(sv));
4450 del_XPVIO(SvANY(sv));
4453 SvFLAGS(sv) &= SVf_BREAK;
4454 SvFLAGS(sv) |= SVTYPEMASK;
4458 Perl_sv_newref(pTHX_ SV *sv)
4461 ATOMIC_INC(SvREFCNT(sv));
4468 Free the memory used by an SV.
4474 Perl_sv_free(pTHX_ SV *sv)
4476 int refcount_is_zero;
4480 if (SvREFCNT(sv) == 0) {
4481 if (SvFLAGS(sv) & SVf_BREAK)
4483 if (PL_in_clean_all) /* All is fair */
4485 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4486 /* make sure SvREFCNT(sv)==0 happens very seldom */
4487 SvREFCNT(sv) = (~(U32)0)/2;
4490 if (ckWARN_d(WARN_INTERNAL))
4491 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4494 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4495 if (!refcount_is_zero)
4499 if (ckWARN_d(WARN_DEBUGGING))
4500 Perl_warner(aTHX_ WARN_DEBUGGING,
4501 "Attempt to free temp prematurely: SV 0x%"UVxf,
4506 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4507 /* make sure SvREFCNT(sv)==0 happens very seldom */
4508 SvREFCNT(sv) = (~(U32)0)/2;
4519 Returns the length of the string in the SV. See also C<SvCUR>.
4525 Perl_sv_len(pTHX_ register SV *sv)
4534 len = mg_length(sv);
4536 junk = SvPV(sv, len);
4541 =for apidoc sv_len_utf8
4543 Returns the number of characters in the string in an SV, counting wide
4544 UTF8 bytes as a single character.
4550 Perl_sv_len_utf8(pTHX_ register SV *sv)
4556 return mg_length(sv);
4560 U8 *s = (U8*)SvPV(sv, len);
4562 return Perl_utf8_length(aTHX_ s, s + len);
4567 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4572 I32 uoffset = *offsetp;
4578 start = s = (U8*)SvPV(sv, len);
4580 while (s < send && uoffset--)
4584 *offsetp = s - start;
4588 while (s < send && ulen--)
4598 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4607 s = (U8*)SvPV(sv, len);
4609 Perl_croak(aTHX_ "panic: bad byte offset");
4610 send = s + *offsetp;
4617 if (ckWARN_d(WARN_UTF8))
4618 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4628 Returns a boolean indicating whether the strings in the two SVs are
4635 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4642 bool pv1tmp = FALSE;
4643 bool pv2tmp = FALSE;
4650 pv1 = SvPV(sv1, cur1);
4657 pv2 = SvPV(sv2, cur2);
4659 /* do not utf8ize the comparands as a side-effect */
4660 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4661 if (PL_hints & HINT_UTF8_DISTINCT)
4665 (void)utf8_to_bytes((U8*)(pv1 = savepvn(pv1, cur1)), &cur1);
4676 (void)utf8_to_bytes((U8*)(pv2 = savepvn(pv2, cur2)), &cur2);
4689 eq = memEQ(pv1, pv2, cur1);
4702 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4703 string in C<sv1> is less than, equal to, or greater than the string in
4710 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4715 bool pv1tmp = FALSE;
4716 bool pv2tmp = FALSE;
4723 pv1 = SvPV(sv1, cur1);
4730 pv2 = SvPV(sv2, cur2);
4732 /* do not utf8ize the comparands as a side-effect */
4733 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4734 if (PL_hints & HINT_UTF8_DISTINCT)
4735 return SvUTF8(sv1) ? 1 : -1;
4738 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4742 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4748 cmp = cur2 ? -1 : 0;
4752 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4755 cmp = retval < 0 ? -1 : 1;
4756 } else if (cur1 == cur2) {
4759 cmp = cur1 < cur2 ? -1 : 1;
4772 =for apidoc sv_cmp_locale
4774 Compares the strings in two SVs in a locale-aware manner. See
4781 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4783 #ifdef USE_LOCALE_COLLATE
4789 if (PL_collation_standard)
4793 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4795 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4797 if (!pv1 || !len1) {
4808 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4811 return retval < 0 ? -1 : 1;
4814 * When the result of collation is equality, that doesn't mean
4815 * that there are no differences -- some locales exclude some
4816 * characters from consideration. So to avoid false equalities,
4817 * we use the raw string as a tiebreaker.
4823 #endif /* USE_LOCALE_COLLATE */
4825 return sv_cmp(sv1, sv2);
4828 #ifdef USE_LOCALE_COLLATE
4830 * Any scalar variable may carry an 'o' magic that contains the
4831 * scalar data of the variable transformed to such a format that
4832 * a normal memory comparison can be used to compare the data
4833 * according to the locale settings.
4836 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4840 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4841 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4846 Safefree(mg->mg_ptr);
4848 if ((xf = mem_collxfrm(s, len, &xlen))) {
4849 if (SvREADONLY(sv)) {
4852 return xf + sizeof(PL_collation_ix);
4855 sv_magic(sv, 0, 'o', 0, 0);
4856 mg = mg_find(sv, 'o');
4869 if (mg && mg->mg_ptr) {
4871 return mg->mg_ptr + sizeof(PL_collation_ix);
4879 #endif /* USE_LOCALE_COLLATE */
4884 Get a line from the filehandle and store it into the SV, optionally
4885 appending to the currently-stored string.
4891 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4895 register STDCHAR rslast;
4896 register STDCHAR *bp;
4900 SV_CHECK_THINKFIRST(sv);
4901 (void)SvUPGRADE(sv, SVt_PV);
4905 if (RsSNARF(PL_rs)) {
4909 else if (RsRECORD(PL_rs)) {
4910 I32 recsize, bytesread;
4913 /* Grab the size of the record we're getting */
4914 recsize = SvIV(SvRV(PL_rs));
4915 (void)SvPOK_only(sv); /* Validate pointer */
4916 buffer = SvGROW(sv, recsize + 1);
4919 /* VMS wants read instead of fread, because fread doesn't respect */
4920 /* RMS record boundaries. This is not necessarily a good thing to be */
4921 /* doing, but we've got no other real choice */
4922 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4924 bytesread = PerlIO_read(fp, buffer, recsize);
4926 SvCUR_set(sv, bytesread);
4927 buffer[bytesread] = '\0';
4928 if (PerlIO_isutf8(fp))
4932 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4934 else if (RsPARA(PL_rs)) {
4939 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4940 if (PerlIO_isutf8(fp)) {
4941 rsptr = SvPVutf8(PL_rs, rslen);
4944 if (SvUTF8(PL_rs)) {
4945 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4946 Perl_croak(aTHX_ "Wide character in $/");
4949 rsptr = SvPV(PL_rs, rslen);
4953 rslast = rslen ? rsptr[rslen - 1] : '\0';
4955 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4956 do { /* to make sure file boundaries work right */
4959 i = PerlIO_getc(fp);
4963 PerlIO_ungetc(fp,i);
4969 /* See if we know enough about I/O mechanism to cheat it ! */
4971 /* This used to be #ifdef test - it is made run-time test for ease
4972 of abstracting out stdio interface. One call should be cheap
4973 enough here - and may even be a macro allowing compile
4977 if (PerlIO_fast_gets(fp)) {
4980 * We're going to steal some values from the stdio struct
4981 * and put EVERYTHING in the innermost loop into registers.
4983 register STDCHAR *ptr;
4987 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4988 /* An ungetc()d char is handled separately from the regular
4989 * buffer, so we getc() it back out and stuff it in the buffer.
4991 i = PerlIO_getc(fp);
4992 if (i == EOF) return 0;
4993 *(--((*fp)->_ptr)) = (unsigned char) i;
4997 /* Here is some breathtakingly efficient cheating */
4999 cnt = PerlIO_get_cnt(fp); /* get count into register */
5000 (void)SvPOK_only(sv); /* validate pointer */
5001 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5002 if (cnt > 80 && SvLEN(sv) > append) {
5003 shortbuffered = cnt - SvLEN(sv) + append + 1;
5004 cnt -= shortbuffered;
5008 /* remember that cnt can be negative */
5009 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5014 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5015 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5016 DEBUG_P(PerlIO_printf(Perl_debug_log,
5017 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5018 DEBUG_P(PerlIO_printf(Perl_debug_log,
5019 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5020 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5021 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5026 while (cnt > 0) { /* this | eat */
5028 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5029 goto thats_all_folks; /* screams | sed :-) */
5033 Copy(ptr, bp, cnt, char); /* this | eat */
5034 bp += cnt; /* screams | dust */
5035 ptr += cnt; /* louder | sed :-) */
5040 if (shortbuffered) { /* oh well, must extend */
5041 cnt = shortbuffered;
5043 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5045 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5046 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5050 DEBUG_P(PerlIO_printf(Perl_debug_log,
5051 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5052 PTR2UV(ptr),(long)cnt));
5053 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5054 DEBUG_P(PerlIO_printf(Perl_debug_log,
5055 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5056 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5057 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5058 /* This used to call 'filbuf' in stdio form, but as that behaves like
5059 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5060 another abstraction. */
5061 i = PerlIO_getc(fp); /* get more characters */
5062 DEBUG_P(PerlIO_printf(Perl_debug_log,
5063 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5064 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5065 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5066 cnt = PerlIO_get_cnt(fp);
5067 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5068 DEBUG_P(PerlIO_printf(Perl_debug_log,
5069 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5071 if (i == EOF) /* all done for ever? */
5072 goto thats_really_all_folks;
5074 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5076 SvGROW(sv, bpx + cnt + 2);
5077 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5079 *bp++ = i; /* store character from PerlIO_getc */
5081 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5082 goto thats_all_folks;
5086 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5087 memNE((char*)bp - rslen, rsptr, rslen))
5088 goto screamer; /* go back to the fray */
5089 thats_really_all_folks:
5091 cnt += shortbuffered;
5092 DEBUG_P(PerlIO_printf(Perl_debug_log,
5093 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5094 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5095 DEBUG_P(PerlIO_printf(Perl_debug_log,
5096 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5097 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5098 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5100 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5101 DEBUG_P(PerlIO_printf(Perl_debug_log,
5102 "Screamer: done, len=%ld, string=|%.*s|\n",
5103 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5108 /*The big, slow, and stupid way */
5111 /* Need to work around EPOC SDK features */
5112 /* On WINS: MS VC5 generates calls to _chkstk, */
5113 /* if a `large' stack frame is allocated */
5114 /* gcc on MARM does not generate calls like these */
5120 register STDCHAR *bpe = buf + sizeof(buf);
5122 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5123 ; /* keep reading */
5127 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5128 /* Accomodate broken VAXC compiler, which applies U8 cast to
5129 * both args of ?: operator, causing EOF to change into 255
5131 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5135 sv_catpvn(sv, (char *) buf, cnt);
5137 sv_setpvn(sv, (char *) buf, cnt);
5139 if (i != EOF && /* joy */
5141 SvCUR(sv) < rslen ||
5142 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5146 * If we're reading from a TTY and we get a short read,
5147 * indicating that the user hit his EOF character, we need
5148 * to notice it now, because if we try to read from the TTY
5149 * again, the EOF condition will disappear.
5151 * The comparison of cnt to sizeof(buf) is an optimization
5152 * that prevents unnecessary calls to feof().
5156 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5161 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5162 while (i != EOF) { /* to make sure file boundaries work right */
5163 i = PerlIO_getc(fp);
5165 PerlIO_ungetc(fp,i);
5171 if (PerlIO_isutf8(fp))
5176 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5183 Auto-increment of the value in the SV.
5189 Perl_sv_inc(pTHX_ register SV *sv)
5198 if (SvTHINKFIRST(sv)) {
5199 if (SvREADONLY(sv)) {
5200 if (PL_curcop != &PL_compiling)
5201 Perl_croak(aTHX_ PL_no_modify);
5205 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5207 i = PTR2IV(SvRV(sv));
5212 flags = SvFLAGS(sv);
5213 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5214 /* It's (privately or publicly) a float, but not tested as an
5215 integer, so test it to see. */
5217 flags = SvFLAGS(sv);
5219 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5220 /* It's publicly an integer, or privately an integer-not-float */
5223 if (SvUVX(sv) == UV_MAX)
5224 sv_setnv(sv, (NV)UV_MAX + 1.0);
5226 (void)SvIOK_only_UV(sv);
5229 if (SvIVX(sv) == IV_MAX)
5230 sv_setuv(sv, (UV)IV_MAX + 1);
5232 (void)SvIOK_only(sv);
5238 if (flags & SVp_NOK) {
5239 (void)SvNOK_only(sv);
5244 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5245 if ((flags & SVTYPEMASK) < SVt_PVIV)
5246 sv_upgrade(sv, SVt_IV);
5247 (void)SvIOK_only(sv);
5252 while (isALPHA(*d)) d++;
5253 while (isDIGIT(*d)) d++;
5255 #ifdef PERL_PRESERVE_IVUV
5256 /* Got to punt this an an integer if needs be, but we don't issue
5257 warnings. Probably ought to make the sv_iv_please() that does
5258 the conversion if possible, and silently. */
5259 I32 numtype = looks_like_number(sv);
5260 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5261 /* Need to try really hard to see if it's an integer.
5262 9.22337203685478e+18 is an integer.
5263 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5264 so $a="9.22337203685478e+18"; $a+0; $a++
5265 needs to be the same as $a="9.22337203685478e+18"; $a++
5272 /* sv_2iv *should* have made this an NV */
5273 if (flags & SVp_NOK) {
5274 (void)SvNOK_only(sv);
5278 /* I don't think we can get here. Maybe I should assert this
5279 And if we do get here I suspect that sv_setnv will croak. NWC
5281 #if defined(USE_LONG_DOUBLE)
5282 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",
5283 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5285 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5286 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5289 #endif /* PERL_PRESERVE_IVUV */
5290 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5294 while (d >= SvPVX(sv)) {
5302 /* MKS: The original code here died if letters weren't consecutive.
5303 * at least it didn't have to worry about non-C locales. The
5304 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5305 * arranged in order (although not consecutively) and that only
5306 * [A-Za-z] are accepted by isALPHA in the C locale.
5308 if (*d != 'z' && *d != 'Z') {
5309 do { ++*d; } while (!isALPHA(*d));
5312 *(d--) -= 'z' - 'a';
5317 *(d--) -= 'z' - 'a' + 1;
5321 /* oh,oh, the number grew */
5322 SvGROW(sv, SvCUR(sv) + 2);
5324 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5335 Auto-decrement of the value in the SV.
5341 Perl_sv_dec(pTHX_ register SV *sv)
5349 if (SvTHINKFIRST(sv)) {
5350 if (SvREADONLY(sv)) {
5351 if (PL_curcop != &PL_compiling)
5352 Perl_croak(aTHX_ PL_no_modify);
5356 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5358 i = PTR2IV(SvRV(sv));
5363 /* Unlike sv_inc we don't have to worry about string-never-numbers
5364 and keeping them magic. But we mustn't warn on punting */
5365 flags = SvFLAGS(sv);
5366 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5367 /* It's publicly an integer, or privately an integer-not-float */
5370 if (SvUVX(sv) == 0) {
5371 (void)SvIOK_only(sv);
5375 (void)SvIOK_only_UV(sv);
5379 if (SvIVX(sv) == IV_MIN)
5380 sv_setnv(sv, (NV)IV_MIN - 1.0);
5382 (void)SvIOK_only(sv);
5388 if (flags & SVp_NOK) {
5390 (void)SvNOK_only(sv);
5393 if (!(flags & SVp_POK)) {
5394 if ((flags & SVTYPEMASK) < SVt_PVNV)
5395 sv_upgrade(sv, SVt_NV);
5397 (void)SvNOK_only(sv);
5400 #ifdef PERL_PRESERVE_IVUV
5402 I32 numtype = looks_like_number(sv);
5403 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5404 /* Need to try really hard to see if it's an integer.
5405 9.22337203685478e+18 is an integer.
5406 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5407 so $a="9.22337203685478e+18"; $a+0; $a--
5408 needs to be the same as $a="9.22337203685478e+18"; $a--
5415 /* sv_2iv *should* have made this an NV */
5416 if (flags & SVp_NOK) {
5417 (void)SvNOK_only(sv);
5421 /* I don't think we can get here. Maybe I should assert this
5422 And if we do get here I suspect that sv_setnv will croak. NWC
5424 #if defined(USE_LONG_DOUBLE)
5425 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",
5426 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5428 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5429 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5433 #endif /* PERL_PRESERVE_IVUV */
5434 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5438 =for apidoc sv_mortalcopy
5440 Creates a new SV which is a copy of the original SV. The new SV is marked
5446 /* Make a string that will exist for the duration of the expression
5447 * evaluation. Actually, it may have to last longer than that, but
5448 * hopefully we won't free it until it has been assigned to a
5449 * permanent location. */
5452 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5457 sv_setsv(sv,oldstr);
5459 PL_tmps_stack[++PL_tmps_ix] = sv;
5465 =for apidoc sv_newmortal
5467 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5473 Perl_sv_newmortal(pTHX)
5478 SvFLAGS(sv) = SVs_TEMP;
5480 PL_tmps_stack[++PL_tmps_ix] = sv;
5485 =for apidoc sv_2mortal
5487 Marks an SV as mortal. The SV will be destroyed when the current context
5493 /* same thing without the copying */
5496 Perl_sv_2mortal(pTHX_ register SV *sv)
5500 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5503 PL_tmps_stack[++PL_tmps_ix] = sv;
5511 Creates a new SV and copies a string into it. The reference count for the
5512 SV is set to 1. If C<len> is zero, Perl will compute the length using
5513 strlen(). For efficiency, consider using C<newSVpvn> instead.
5519 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5526 sv_setpvn(sv,s,len);
5531 =for apidoc newSVpvn
5533 Creates a new SV and copies a string into it. The reference count for the
5534 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5535 string. You are responsible for ensuring that the source string is at least
5542 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5547 sv_setpvn(sv,s,len);
5552 =for apidoc newSVpvn_share
5554 Creates a new SV and populates it with a string from
5555 the string table. Turns on READONLY and FAKE.
5556 The idea here is that as string table is used for shared hash
5557 keys these strings will have SvPVX == HeKEY and hash lookup
5558 will avoid string compare.
5564 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5567 bool is_utf8 = FALSE;
5573 PERL_HASH(hash, src, len);
5575 sv_upgrade(sv, SVt_PVIV);
5576 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5588 #if defined(PERL_IMPLICIT_CONTEXT)
5590 Perl_newSVpvf_nocontext(const char* pat, ...)
5595 va_start(args, pat);
5596 sv = vnewSVpvf(pat, &args);
5603 =for apidoc newSVpvf
5605 Creates a new SV an initialize it with the string formatted like
5612 Perl_newSVpvf(pTHX_ const char* pat, ...)
5616 va_start(args, pat);
5617 sv = vnewSVpvf(pat, &args);
5623 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5627 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5634 Creates a new SV and copies a floating point value into it.
5635 The reference count for the SV is set to 1.
5641 Perl_newSVnv(pTHX_ NV n)
5653 Creates a new SV and copies an integer into it. The reference count for the
5660 Perl_newSViv(pTHX_ IV i)
5672 Creates a new SV and copies an unsigned integer into it.
5673 The reference count for the SV is set to 1.
5679 Perl_newSVuv(pTHX_ UV u)
5689 =for apidoc newRV_noinc
5691 Creates an RV wrapper for an SV. The reference count for the original
5692 SV is B<not> incremented.
5698 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5703 sv_upgrade(sv, SVt_RV);
5710 /* newRV_inc is #defined to newRV in sv.h */
5712 Perl_newRV(pTHX_ SV *tmpRef)
5714 return newRV_noinc(SvREFCNT_inc(tmpRef));
5720 Creates a new SV which is an exact duplicate of the original SV.
5725 /* make an exact duplicate of old */
5728 Perl_newSVsv(pTHX_ register SV *old)
5734 if (SvTYPE(old) == SVTYPEMASK) {
5735 if (ckWARN_d(WARN_INTERNAL))
5736 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5751 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5759 char todo[PERL_UCHAR_MAX+1];
5764 if (!*s) { /* reset ?? searches */
5765 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5766 pm->op_pmdynflags &= ~PMdf_USED;
5771 /* reset variables */
5773 if (!HvARRAY(stash))
5776 Zero(todo, 256, char);
5778 i = (unsigned char)*s;
5782 max = (unsigned char)*s++;
5783 for ( ; i <= max; i++) {
5786 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5787 for (entry = HvARRAY(stash)[i];
5789 entry = HeNEXT(entry))
5791 if (!todo[(U8)*HeKEY(entry)])
5793 gv = (GV*)HeVAL(entry);
5795 if (SvTHINKFIRST(sv)) {
5796 if (!SvREADONLY(sv) && SvROK(sv))
5801 if (SvTYPE(sv) >= SVt_PV) {
5803 if (SvPVX(sv) != Nullch)
5810 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5812 #ifdef USE_ENVIRON_ARRAY
5814 environ[0] = Nullch;
5823 Perl_sv_2io(pTHX_ SV *sv)
5829 switch (SvTYPE(sv)) {
5837 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5841 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5843 return sv_2io(SvRV(sv));
5844 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5850 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5857 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5864 return *gvp = Nullgv, Nullcv;
5865 switch (SvTYPE(sv)) {
5884 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5885 tryAMAGICunDEREF(to_cv);
5888 if (SvTYPE(sv) == SVt_PVCV) {
5897 Perl_croak(aTHX_ "Not a subroutine reference");
5902 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5908 if (lref && !GvCVu(gv)) {
5911 tmpsv = NEWSV(704,0);
5912 gv_efullname3(tmpsv, gv, Nullch);
5913 /* XXX this is probably not what they think they're getting.
5914 * It has the same effect as "sub name;", i.e. just a forward
5916 newSUB(start_subparse(FALSE, 0),
5917 newSVOP(OP_CONST, 0, tmpsv),
5922 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5931 Returns true if the SV has a true value by Perl's rules.
5937 Perl_sv_true(pTHX_ register SV *sv)
5943 if ((tXpv = (XPV*)SvANY(sv)) &&
5944 (tXpv->xpv_cur > 1 ||
5945 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5952 return SvIVX(sv) != 0;
5955 return SvNVX(sv) != 0.0;
5957 return sv_2bool(sv);
5963 Perl_sv_iv(pTHX_ register SV *sv)
5967 return (IV)SvUVX(sv);
5974 Perl_sv_uv(pTHX_ register SV *sv)
5979 return (UV)SvIVX(sv);
5985 Perl_sv_nv(pTHX_ register SV *sv)
5993 Perl_sv_pv(pTHX_ SV *sv)
6000 return sv_2pv(sv, &n_a);
6004 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6010 return sv_2pv(sv, lp);
6014 =for apidoc sv_pvn_force
6016 Get a sensible string out of the SV somehow.
6022 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6026 if (SvTHINKFIRST(sv) && !SvROK(sv))
6027 sv_force_normal(sv);
6033 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6034 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6035 PL_op_name[PL_op->op_type]);
6039 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6044 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6045 SvGROW(sv, len + 1);
6046 Move(s,SvPVX(sv),len,char);
6051 SvPOK_on(sv); /* validate pointer */
6053 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6054 PTR2UV(sv),SvPVX(sv)));
6061 Perl_sv_pvbyte(pTHX_ SV *sv)
6067 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6069 return sv_pvn(sv,lp);
6073 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6075 return sv_pvn_force(sv,lp);
6079 Perl_sv_pvutf8(pTHX_ SV *sv)
6081 sv_utf8_upgrade(sv);
6086 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6088 sv_utf8_upgrade(sv);
6089 return sv_pvn(sv,lp);
6093 =for apidoc sv_pvutf8n_force
6095 Get a sensible UTF8-encoded string out of the SV somehow. See
6102 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6104 sv_utf8_upgrade(sv);
6105 return sv_pvn_force(sv,lp);
6109 =for apidoc sv_reftype
6111 Returns a string describing what the SV is a reference to.
6117 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6119 if (ob && SvOBJECT(sv))
6120 return HvNAME(SvSTASH(sv));
6122 switch (SvTYPE(sv)) {
6136 case SVt_PVLV: return "LVALUE";
6137 case SVt_PVAV: return "ARRAY";
6138 case SVt_PVHV: return "HASH";
6139 case SVt_PVCV: return "CODE";
6140 case SVt_PVGV: return "GLOB";
6141 case SVt_PVFM: return "FORMAT";
6142 case SVt_PVIO: return "IO";
6143 default: return "UNKNOWN";
6149 =for apidoc sv_isobject
6151 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6152 object. If the SV is not an RV, or if the object is not blessed, then this
6159 Perl_sv_isobject(pTHX_ SV *sv)
6176 Returns a boolean indicating whether the SV is blessed into the specified
6177 class. This does not check for subtypes; use C<sv_derived_from> to verify
6178 an inheritance relationship.
6184 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6196 return strEQ(HvNAME(SvSTASH(sv)), name);
6202 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6203 it will be upgraded to one. If C<classname> is non-null then the new SV will
6204 be blessed in the specified package. The new SV is returned and its
6205 reference count is 1.
6211 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6217 SV_CHECK_THINKFIRST(rv);
6220 if (SvTYPE(rv) >= SVt_PVMG) {
6221 U32 refcnt = SvREFCNT(rv);
6225 SvREFCNT(rv) = refcnt;
6228 if (SvTYPE(rv) < SVt_RV)
6229 sv_upgrade(rv, SVt_RV);
6230 else if (SvTYPE(rv) > SVt_RV) {
6231 (void)SvOOK_off(rv);
6232 if (SvPVX(rv) && SvLEN(rv))
6233 Safefree(SvPVX(rv));
6243 HV* stash = gv_stashpv(classname, TRUE);
6244 (void)sv_bless(rv, stash);
6250 =for apidoc sv_setref_pv
6252 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6253 argument will be upgraded to an RV. That RV will be modified to point to
6254 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6255 into the SV. The C<classname> argument indicates the package for the
6256 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6257 will be returned and will have a reference count of 1.
6259 Do not use with other Perl types such as HV, AV, SV, CV, because those
6260 objects will become corrupted by the pointer copy process.
6262 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6268 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6271 sv_setsv(rv, &PL_sv_undef);
6275 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6280 =for apidoc sv_setref_iv
6282 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6283 argument will be upgraded to an RV. That RV will be modified to point to
6284 the new SV. The C<classname> argument indicates the package for the
6285 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6286 will be returned and will have a reference count of 1.
6292 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6294 sv_setiv(newSVrv(rv,classname), iv);
6299 =for apidoc sv_setref_nv
6301 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6302 argument will be upgraded to an RV. That RV will be modified to point to
6303 the new SV. The C<classname> argument indicates the package for the
6304 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6305 will be returned and will have a reference count of 1.
6311 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6313 sv_setnv(newSVrv(rv,classname), nv);
6318 =for apidoc sv_setref_pvn
6320 Copies a string into a new SV, optionally blessing the SV. The length of the
6321 string must be specified with C<n>. The C<rv> argument will be upgraded to
6322 an RV. That RV will be modified to point to the new SV. The C<classname>
6323 argument indicates the package for the blessing. Set C<classname> to
6324 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6325 a reference count of 1.
6327 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6333 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6335 sv_setpvn(newSVrv(rv,classname), pv, n);
6340 =for apidoc sv_bless
6342 Blesses an SV into a specified package. The SV must be an RV. The package
6343 must be designated by its stash (see C<gv_stashpv()>). The reference count
6344 of the SV is unaffected.
6350 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6354 Perl_croak(aTHX_ "Can't bless non-reference value");
6356 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6357 if (SvREADONLY(tmpRef))
6358 Perl_croak(aTHX_ PL_no_modify);
6359 if (SvOBJECT(tmpRef)) {
6360 if (SvTYPE(tmpRef) != SVt_PVIO)
6362 SvREFCNT_dec(SvSTASH(tmpRef));
6365 SvOBJECT_on(tmpRef);
6366 if (SvTYPE(tmpRef) != SVt_PVIO)
6368 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6369 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6380 S_sv_unglob(pTHX_ SV *sv)
6384 assert(SvTYPE(sv) == SVt_PVGV);
6389 SvREFCNT_dec(GvSTASH(sv));
6390 GvSTASH(sv) = Nullhv;
6392 sv_unmagic(sv, '*');
6393 Safefree(GvNAME(sv));
6396 /* need to keep SvANY(sv) in the right arena */
6397 xpvmg = new_XPVMG();
6398 StructCopy(SvANY(sv), xpvmg, XPVMG);
6399 del_XPVGV(SvANY(sv));
6402 SvFLAGS(sv) &= ~SVTYPEMASK;
6403 SvFLAGS(sv) |= SVt_PVMG;
6407 =for apidoc sv_unref_flags
6409 Unsets the RV status of the SV, and decrements the reference count of
6410 whatever was being referenced by the RV. This can almost be thought of
6411 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6412 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6413 (otherwise the decrementing is conditional on the reference count being
6414 different from one or the reference being a readonly SV).
6421 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6425 if (SvWEAKREF(sv)) {
6433 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6435 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6436 sv_2mortal(rv); /* Schedule for freeing later */
6440 =for apidoc sv_unref
6442 Unsets the RV status of the SV, and decrements the reference count of
6443 whatever was being referenced by the RV. This can almost be thought of
6444 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6445 being zero. See C<SvROK_off>.
6451 Perl_sv_unref(pTHX_ SV *sv)
6453 sv_unref_flags(sv, 0);
6457 Perl_sv_taint(pTHX_ SV *sv)
6459 sv_magic((sv), Nullsv, 't', Nullch, 0);
6463 Perl_sv_untaint(pTHX_ SV *sv)
6465 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6466 MAGIC *mg = mg_find(sv, 't');
6473 Perl_sv_tainted(pTHX_ SV *sv)
6475 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6476 MAGIC *mg = mg_find(sv, 't');
6477 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6484 =for apidoc sv_setpviv
6486 Copies an integer into the given SV, also updating its string value.
6487 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6493 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6495 char buf[TYPE_CHARS(UV)];
6497 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6499 sv_setpvn(sv, ptr, ebuf - ptr);
6504 =for apidoc sv_setpviv_mg
6506 Like C<sv_setpviv>, but also handles 'set' magic.
6512 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6514 char buf[TYPE_CHARS(UV)];
6516 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6518 sv_setpvn(sv, ptr, ebuf - ptr);
6522 #if defined(PERL_IMPLICIT_CONTEXT)
6524 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6528 va_start(args, pat);
6529 sv_vsetpvf(sv, pat, &args);
6535 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6539 va_start(args, pat);
6540 sv_vsetpvf_mg(sv, pat, &args);
6546 =for apidoc sv_setpvf
6548 Processes its arguments like C<sprintf> and sets an SV to the formatted
6549 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6555 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6558 va_start(args, pat);
6559 sv_vsetpvf(sv, pat, &args);
6564 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6566 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6570 =for apidoc sv_setpvf_mg
6572 Like C<sv_setpvf>, but also handles 'set' magic.
6578 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6581 va_start(args, pat);
6582 sv_vsetpvf_mg(sv, pat, &args);
6587 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6589 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6593 #if defined(PERL_IMPLICIT_CONTEXT)
6595 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6599 va_start(args, pat);
6600 sv_vcatpvf(sv, pat, &args);
6605 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6609 va_start(args, pat);
6610 sv_vcatpvf_mg(sv, pat, &args);
6616 =for apidoc sv_catpvf
6618 Processes its arguments like C<sprintf> and appends the formatted output
6619 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6620 typically be called after calling this function to handle 'set' magic.
6626 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6629 va_start(args, pat);
6630 sv_vcatpvf(sv, pat, &args);
6635 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6637 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6641 =for apidoc sv_catpvf_mg
6643 Like C<sv_catpvf>, but also handles 'set' magic.
6649 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6652 va_start(args, pat);
6653 sv_vcatpvf_mg(sv, pat, &args);
6658 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6660 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6665 =for apidoc sv_vsetpvfn
6667 Works like C<vcatpvfn> but copies the text into the SV instead of
6674 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6676 sv_setpvn(sv, "", 0);
6677 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6681 =for apidoc sv_vcatpvfn
6683 Processes its arguments like C<vsprintf> and appends the formatted output
6684 to an SV. Uses an array of SVs if the C style variable argument list is
6685 missing (NULL). When running with taint checks enabled, indicates via
6686 C<maybe_tainted> if results are untrustworthy (often due to the use of
6693 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6700 static char nullstr[] = "(null)";
6703 /* no matter what, this is a string now */
6704 (void)SvPV_force(sv, origlen);
6706 /* special-case "", "%s", and "%_" */
6709 if (patlen == 2 && pat[0] == '%') {
6713 char *s = va_arg(*args, char*);
6714 sv_catpv(sv, s ? s : nullstr);
6716 else if (svix < svmax) {
6717 sv_catsv(sv, *svargs);
6718 if (DO_UTF8(*svargs))
6724 argsv = va_arg(*args, SV*);
6725 sv_catsv(sv, argsv);
6730 /* See comment on '_' below */
6735 patend = (char*)pat + patlen;
6736 for (p = (char*)pat; p < patend; p = q) {
6739 bool vectorize = FALSE;
6746 bool has_precis = FALSE;
6748 bool is_utf = FALSE;
6751 U8 utf8buf[UTF8_MAXLEN+1];
6752 STRLEN esignlen = 0;
6754 char *eptr = Nullch;
6756 /* Times 4: a decimal digit takes more than 3 binary digits.
6757 * NV_DIG: mantissa takes than many decimal digits.
6758 * Plus 32: Playing safe. */
6759 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6760 /* large enough for "%#.#f" --chip */
6761 /* what about long double NVs? --jhi */
6764 U8 *vecstr = Null(U8*);
6776 STRLEN dotstrlen = 1;
6777 I32 epix = 0; /* explicit parameter index */
6778 I32 ewix = 0; /* explicit width index */
6779 bool asterisk = FALSE;
6781 for (q = p; q < patend && *q != '%'; ++q) ;
6783 sv_catpvn(sv, p, q - p);
6812 case '*': /* printf("%*vX",":",$ipv6addr) */
6817 vecsv = va_arg(*args, SV*);
6818 else if (svix < svmax)
6819 vecsv = svargs[svix++];
6822 dotstr = SvPVx(vecsv,dotstrlen);
6850 case '1': case '2': case '3':
6851 case '4': case '5': case '6':
6852 case '7': case '8': case '9':
6855 width = width * 10 + (*q++ - '0');
6857 if (asterisk && ewix == 0) {
6862 } else if (epix == 0) {
6874 i = va_arg(*args, int);
6876 i = (ewix ? ewix <= svmax : svix < svmax) ?
6877 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6879 width = (i < 0) ? -i : i;
6888 i = va_arg(*args, int);
6890 i = (ewix ? ewix <= svmax : svix < svmax)
6891 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6892 precis = (i < 0) ? 0 : i;
6898 precis = precis * 10 + (*q++ - '0');
6905 vecsv = va_arg(*args, SV*);
6906 vecstr = (U8*)SvPVx(vecsv,veclen);
6907 utf = DO_UTF8(vecsv);
6909 else if (epix ? epix <= svmax : svix < svmax) {
6910 vecsv = svargs[epix ? epix-1 : svix++];
6911 vecstr = (U8*)SvPVx(vecsv,veclen);
6912 utf = DO_UTF8(vecsv);
6923 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6934 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6935 if (*(q + 1) == 'l') { /* lld, llf */
6962 uv = va_arg(*args, int);
6964 uv = (epix ? epix <= svmax : svix < svmax) ?
6965 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6966 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6967 eptr = (char*)utf8buf;
6968 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6980 eptr = va_arg(*args, char*);
6982 #ifdef MACOS_TRADITIONAL
6983 /* On MacOS, %#s format is used for Pascal strings */
6988 elen = strlen(eptr);
6991 elen = sizeof nullstr - 1;
6994 else if (epix ? epix <= svmax : svix < svmax) {
6995 argsv = svargs[epix ? epix-1 : svix++];
6996 eptr = SvPVx(argsv, elen);
6997 if (DO_UTF8(argsv)) {
6998 if (has_precis && precis < elen) {
7000 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7003 if (width) { /* fudge width (can't fudge elen) */
7004 width += elen - sv_len_utf8(argsv);
7013 * The "%_" hack might have to be changed someday,
7014 * if ISO or ANSI decide to use '_' for something.
7015 * So we keep it hidden from users' code.
7019 argsv = va_arg(*args,SV*);
7020 eptr = SvPVx(argsv, elen);
7026 if (has_precis && elen > precis)
7036 uv = PTR2UV(va_arg(*args, void*));
7038 uv = (epix ? epix <= svmax : svix < svmax) ?
7039 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
7059 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7069 case 'h': iv = (short)va_arg(*args, int); break;
7070 default: iv = va_arg(*args, int); break;
7071 case 'l': iv = va_arg(*args, long); break;
7072 case 'V': iv = va_arg(*args, IV); break;
7074 case 'q': iv = va_arg(*args, Quad_t); break;
7079 iv = (epix ? epix <= svmax : svix < svmax) ?
7080 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
7082 case 'h': iv = (short)iv; break;
7084 case 'l': iv = (long)iv; break;
7087 case 'q': iv = (Quad_t)iv; break;
7094 esignbuf[esignlen++] = plus;
7098 esignbuf[esignlen++] = '-';
7142 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7152 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7153 default: uv = va_arg(*args, unsigned); break;
7154 case 'l': uv = va_arg(*args, unsigned long); break;
7155 case 'V': uv = va_arg(*args, UV); break;
7157 case 'q': uv = va_arg(*args, Quad_t); break;
7162 uv = (epix ? epix <= svmax : svix < svmax) ?
7163 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
7165 case 'h': uv = (unsigned short)uv; break;
7167 case 'l': uv = (unsigned long)uv; break;
7170 case 'q': uv = (Quad_t)uv; break;
7176 eptr = ebuf + sizeof ebuf;
7182 p = (char*)((c == 'X')
7183 ? "0123456789ABCDEF" : "0123456789abcdef");
7189 esignbuf[esignlen++] = '0';
7190 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7196 *--eptr = '0' + dig;
7198 if (alt && *eptr != '0')
7204 *--eptr = '0' + dig;
7207 esignbuf[esignlen++] = '0';
7208 esignbuf[esignlen++] = 'b';
7211 default: /* it had better be ten or less */
7212 #if defined(PERL_Y2KWARN)
7213 if (ckWARN(WARN_Y2K)) {
7215 char *s = SvPV(sv,n);
7216 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7217 && (n == 2 || !isDIGIT(s[n-3])))
7219 Perl_warner(aTHX_ WARN_Y2K,
7220 "Possible Y2K bug: %%%c %s",
7221 c, "format string following '19'");
7227 *--eptr = '0' + dig;
7228 } while (uv /= base);
7231 elen = (ebuf + sizeof ebuf) - eptr;
7234 zeros = precis - elen;
7235 else if (precis == 0 && elen == 1 && *eptr == '0')
7240 /* FLOATING POINT */
7243 c = 'f'; /* maybe %F isn't supported here */
7249 /* This is evil, but floating point is even more evil */
7253 nv = va_arg(*args, NV);
7255 nv = (epix ? epix <= svmax : svix < svmax) ?
7256 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
7259 if (c != 'e' && c != 'E') {
7261 (void)Perl_frexp(nv, &i);
7262 if (i == PERL_INT_MIN)
7263 Perl_die(aTHX_ "panic: frexp");
7265 need = BIT_DIGITS(i);
7267 need += has_precis ? precis : 6; /* known default */
7271 need += 20; /* fudge factor */
7272 if (PL_efloatsize < need) {
7273 Safefree(PL_efloatbuf);
7274 PL_efloatsize = need + 20; /* more fudge */
7275 New(906, PL_efloatbuf, PL_efloatsize, char);
7276 PL_efloatbuf[0] = '\0';
7279 eptr = ebuf + sizeof ebuf;
7282 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7284 /* Copy the one or more characters in a long double
7285 * format before the 'base' ([efgEFG]) character to
7286 * the format string. */
7287 static char const prifldbl[] = PERL_PRIfldbl;
7288 char const *p = prifldbl + sizeof(prifldbl) - 3;
7289 while (p >= prifldbl) { *--eptr = *p--; }
7294 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7299 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7311 /* No taint. Otherwise we are in the strange situation
7312 * where printf() taints but print($float) doesn't.
7314 (void)sprintf(PL_efloatbuf, eptr, nv);
7316 eptr = PL_efloatbuf;
7317 elen = strlen(PL_efloatbuf);
7324 i = SvCUR(sv) - origlen;
7327 case 'h': *(va_arg(*args, short*)) = i; break;
7328 default: *(va_arg(*args, int*)) = i; break;
7329 case 'l': *(va_arg(*args, long*)) = i; break;
7330 case 'V': *(va_arg(*args, IV*)) = i; break;
7332 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7336 else if (epix ? epix <= svmax : svix < svmax)
7337 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
7338 continue; /* not "break" */
7345 if (!args && ckWARN(WARN_PRINTF) &&
7346 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7347 SV *msg = sv_newmortal();
7348 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7349 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7352 Perl_sv_catpvf(aTHX_ msg,
7353 "\"%%%c\"", c & 0xFF);
7355 Perl_sv_catpvf(aTHX_ msg,
7356 "\"%%\\%03"UVof"\"",
7359 sv_catpv(msg, "end of string");
7360 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7363 /* output mangled stuff ... */
7369 /* ... right here, because formatting flags should not apply */
7370 SvGROW(sv, SvCUR(sv) + elen + 1);
7372 memcpy(p, eptr, elen);
7375 SvCUR(sv) = p - SvPVX(sv);
7376 continue; /* not "break" */
7379 have = esignlen + zeros + elen;
7380 need = (have > width ? have : width);
7383 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7385 if (esignlen && fill == '0') {
7386 for (i = 0; i < esignlen; i++)
7390 memset(p, fill, gap);
7393 if (esignlen && fill != '0') {
7394 for (i = 0; i < esignlen; i++)
7398 for (i = zeros; i; i--)
7402 memcpy(p, eptr, elen);
7406 memset(p, ' ', gap);
7411 memcpy(p, dotstr, dotstrlen);
7415 vectorize = FALSE; /* done iterating over vecstr */
7420 SvCUR(sv) = p - SvPVX(sv);
7428 #if defined(USE_ITHREADS)
7430 #if defined(USE_THREADS)
7431 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7434 #ifndef GpREFCNT_inc
7435 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7439 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7440 #define av_dup(s) (AV*)sv_dup((SV*)s)
7441 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7442 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7443 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7444 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7445 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7446 #define io_dup(s) (IO*)sv_dup((SV*)s)
7447 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7448 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7449 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7450 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7451 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7454 Perl_re_dup(pTHX_ REGEXP *r)
7456 /* XXX fix when pmop->op_pmregexp becomes shared */
7457 return ReREFCNT_inc(r);
7461 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7465 return (PerlIO*)NULL;
7467 /* look for it in the table first */
7468 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7472 /* create anew and remember what it is */
7473 ret = PerlIO_fdupopen(aTHX_ fp);
7474 ptr_table_store(PL_ptr_table, fp, ret);
7479 Perl_dirp_dup(pTHX_ DIR *dp)
7488 Perl_gp_dup(pTHX_ GP *gp)
7493 /* look for it in the table first */
7494 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7498 /* create anew and remember what it is */
7499 Newz(0, ret, 1, GP);
7500 ptr_table_store(PL_ptr_table, gp, ret);
7503 ret->gp_refcnt = 0; /* must be before any other dups! */
7504 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7505 ret->gp_io = io_dup_inc(gp->gp_io);
7506 ret->gp_form = cv_dup_inc(gp->gp_form);
7507 ret->gp_av = av_dup_inc(gp->gp_av);
7508 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7509 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7510 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7511 ret->gp_cvgen = gp->gp_cvgen;
7512 ret->gp_flags = gp->gp_flags;
7513 ret->gp_line = gp->gp_line;
7514 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7519 Perl_mg_dup(pTHX_ MAGIC *mg)
7521 MAGIC *mgret = (MAGIC*)NULL;
7524 return (MAGIC*)NULL;
7525 /* look for it in the table first */
7526 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7530 for (; mg; mg = mg->mg_moremagic) {
7532 Newz(0, nmg, 1, MAGIC);
7536 mgprev->mg_moremagic = nmg;
7537 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7538 nmg->mg_private = mg->mg_private;
7539 nmg->mg_type = mg->mg_type;
7540 nmg->mg_flags = mg->mg_flags;
7541 if (mg->mg_type == 'r') {
7542 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7545 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7546 ? sv_dup_inc(mg->mg_obj)
7547 : sv_dup(mg->mg_obj);
7549 nmg->mg_len = mg->mg_len;
7550 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7551 if (mg->mg_ptr && mg->mg_type != 'g') {
7552 if (mg->mg_len >= 0) {
7553 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7554 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7555 AMT *amtp = (AMT*)mg->mg_ptr;
7556 AMT *namtp = (AMT*)nmg->mg_ptr;
7558 for (i = 1; i < NofAMmeth; i++) {
7559 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7563 else if (mg->mg_len == HEf_SVKEY)
7564 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7572 Perl_ptr_table_new(pTHX)
7575 Newz(0, tbl, 1, PTR_TBL_t);
7578 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7583 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7585 PTR_TBL_ENT_t *tblent;
7586 UV hash = PTR2UV(sv);
7588 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7589 for (; tblent; tblent = tblent->next) {
7590 if (tblent->oldval == sv)
7591 return tblent->newval;
7597 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7599 PTR_TBL_ENT_t *tblent, **otblent;
7600 /* XXX this may be pessimal on platforms where pointers aren't good
7601 * hash values e.g. if they grow faster in the most significant
7603 UV hash = PTR2UV(oldv);
7607 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7608 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7609 if (tblent->oldval == oldv) {
7610 tblent->newval = newv;
7615 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7616 tblent->oldval = oldv;
7617 tblent->newval = newv;
7618 tblent->next = *otblent;
7621 if (i && tbl->tbl_items > tbl->tbl_max)
7622 ptr_table_split(tbl);
7626 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7628 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7629 UV oldsize = tbl->tbl_max + 1;
7630 UV newsize = oldsize * 2;
7633 Renew(ary, newsize, PTR_TBL_ENT_t*);
7634 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7635 tbl->tbl_max = --newsize;
7637 for (i=0; i < oldsize; i++, ary++) {
7638 PTR_TBL_ENT_t **curentp, **entp, *ent;
7641 curentp = ary + oldsize;
7642 for (entp = ary, ent = *ary; ent; ent = *entp) {
7643 if ((newsize & PTR2UV(ent->oldval)) != i) {
7645 ent->next = *curentp;
7660 Perl_sv_dup(pTHX_ SV *sstr)
7664 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7666 /* look for it in the table first */
7667 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7671 /* create anew and remember what it is */
7673 ptr_table_store(PL_ptr_table, sstr, dstr);
7676 SvFLAGS(dstr) = SvFLAGS(sstr);
7677 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7678 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7681 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7682 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7683 PL_watch_pvx, SvPVX(sstr));
7686 switch (SvTYPE(sstr)) {
7691 SvANY(dstr) = new_XIV();
7692 SvIVX(dstr) = SvIVX(sstr);
7695 SvANY(dstr) = new_XNV();
7696 SvNVX(dstr) = SvNVX(sstr);
7699 SvANY(dstr) = new_XRV();
7700 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7703 SvANY(dstr) = new_XPV();
7704 SvCUR(dstr) = SvCUR(sstr);
7705 SvLEN(dstr) = SvLEN(sstr);
7707 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7708 else if (SvPVX(sstr) && SvLEN(sstr))
7709 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7711 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7714 SvANY(dstr) = new_XPVIV();
7715 SvCUR(dstr) = SvCUR(sstr);
7716 SvLEN(dstr) = SvLEN(sstr);
7717 SvIVX(dstr) = SvIVX(sstr);
7719 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7720 else if (SvPVX(sstr) && SvLEN(sstr))
7721 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7723 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7726 SvANY(dstr) = new_XPVNV();
7727 SvCUR(dstr) = SvCUR(sstr);
7728 SvLEN(dstr) = SvLEN(sstr);
7729 SvIVX(dstr) = SvIVX(sstr);
7730 SvNVX(dstr) = SvNVX(sstr);
7732 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7733 else if (SvPVX(sstr) && SvLEN(sstr))
7734 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7736 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7739 SvANY(dstr) = new_XPVMG();
7740 SvCUR(dstr) = SvCUR(sstr);
7741 SvLEN(dstr) = SvLEN(sstr);
7742 SvIVX(dstr) = SvIVX(sstr);
7743 SvNVX(dstr) = SvNVX(sstr);
7744 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7745 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7747 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7748 else if (SvPVX(sstr) && SvLEN(sstr))
7749 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7751 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7754 SvANY(dstr) = new_XPVBM();
7755 SvCUR(dstr) = SvCUR(sstr);
7756 SvLEN(dstr) = SvLEN(sstr);
7757 SvIVX(dstr) = SvIVX(sstr);
7758 SvNVX(dstr) = SvNVX(sstr);
7759 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7760 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7762 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7763 else if (SvPVX(sstr) && SvLEN(sstr))
7764 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7766 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7767 BmRARE(dstr) = BmRARE(sstr);
7768 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7769 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7772 SvANY(dstr) = new_XPVLV();
7773 SvCUR(dstr) = SvCUR(sstr);
7774 SvLEN(dstr) = SvLEN(sstr);
7775 SvIVX(dstr) = SvIVX(sstr);
7776 SvNVX(dstr) = SvNVX(sstr);
7777 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7778 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7780 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7781 else if (SvPVX(sstr) && SvLEN(sstr))
7782 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7784 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7785 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7786 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7787 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7788 LvTYPE(dstr) = LvTYPE(sstr);
7791 SvANY(dstr) = new_XPVGV();
7792 SvCUR(dstr) = SvCUR(sstr);
7793 SvLEN(dstr) = SvLEN(sstr);
7794 SvIVX(dstr) = SvIVX(sstr);
7795 SvNVX(dstr) = SvNVX(sstr);
7796 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7797 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7799 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7800 else if (SvPVX(sstr) && SvLEN(sstr))
7801 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7803 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7804 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7805 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7806 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7807 GvFLAGS(dstr) = GvFLAGS(sstr);
7808 GvGP(dstr) = gp_dup(GvGP(sstr));
7809 (void)GpREFCNT_inc(GvGP(dstr));
7812 SvANY(dstr) = new_XPVIO();
7813 SvCUR(dstr) = SvCUR(sstr);
7814 SvLEN(dstr) = SvLEN(sstr);
7815 SvIVX(dstr) = SvIVX(sstr);
7816 SvNVX(dstr) = SvNVX(sstr);
7817 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7818 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7820 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7821 else if (SvPVX(sstr) && SvLEN(sstr))
7822 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7824 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7825 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7826 if (IoOFP(sstr) == IoIFP(sstr))
7827 IoOFP(dstr) = IoIFP(dstr);
7829 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7830 /* PL_rsfp_filters entries have fake IoDIRP() */
7831 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7832 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7834 IoDIRP(dstr) = IoDIRP(sstr);
7835 IoLINES(dstr) = IoLINES(sstr);
7836 IoPAGE(dstr) = IoPAGE(sstr);
7837 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7838 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7839 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7840 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7841 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7842 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7843 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7844 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7845 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7846 IoTYPE(dstr) = IoTYPE(sstr);
7847 IoFLAGS(dstr) = IoFLAGS(sstr);
7850 SvANY(dstr) = new_XPVAV();
7851 SvCUR(dstr) = SvCUR(sstr);
7852 SvLEN(dstr) = SvLEN(sstr);
7853 SvIVX(dstr) = SvIVX(sstr);
7854 SvNVX(dstr) = SvNVX(sstr);
7855 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7856 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7857 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7858 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7859 if (AvARRAY((AV*)sstr)) {
7860 SV **dst_ary, **src_ary;
7861 SSize_t items = AvFILLp((AV*)sstr) + 1;
7863 src_ary = AvARRAY((AV*)sstr);
7864 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7865 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7866 SvPVX(dstr) = (char*)dst_ary;
7867 AvALLOC((AV*)dstr) = dst_ary;
7868 if (AvREAL((AV*)sstr)) {
7870 *dst_ary++ = sv_dup_inc(*src_ary++);
7874 *dst_ary++ = sv_dup(*src_ary++);
7876 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7877 while (items-- > 0) {
7878 *dst_ary++ = &PL_sv_undef;
7882 SvPVX(dstr) = Nullch;
7883 AvALLOC((AV*)dstr) = (SV**)NULL;
7887 SvANY(dstr) = new_XPVHV();
7888 SvCUR(dstr) = SvCUR(sstr);
7889 SvLEN(dstr) = SvLEN(sstr);
7890 SvIVX(dstr) = SvIVX(sstr);
7891 SvNVX(dstr) = SvNVX(sstr);
7892 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7893 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7894 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7895 if (HvARRAY((HV*)sstr)) {
7897 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7898 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7899 Newz(0, dxhv->xhv_array,
7900 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7901 while (i <= sxhv->xhv_max) {
7902 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7903 !!HvSHAREKEYS(sstr));
7906 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7909 SvPVX(dstr) = Nullch;
7910 HvEITER((HV*)dstr) = (HE*)NULL;
7912 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7913 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7916 SvANY(dstr) = new_XPVFM();
7917 FmLINES(dstr) = FmLINES(sstr);
7921 SvANY(dstr) = new_XPVCV();
7923 SvCUR(dstr) = SvCUR(sstr);
7924 SvLEN(dstr) = SvLEN(sstr);
7925 SvIVX(dstr) = SvIVX(sstr);
7926 SvNVX(dstr) = SvNVX(sstr);
7927 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7928 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7929 if (SvPVX(sstr) && SvLEN(sstr))
7930 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7932 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7933 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7934 CvSTART(dstr) = CvSTART(sstr);
7935 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7936 CvXSUB(dstr) = CvXSUB(sstr);
7937 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7938 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7939 CvDEPTH(dstr) = CvDEPTH(sstr);
7940 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7941 /* XXX padlists are real, but pretend to be not */
7942 AvREAL_on(CvPADLIST(sstr));
7943 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7944 AvREAL_off(CvPADLIST(sstr));
7945 AvREAL_off(CvPADLIST(dstr));
7948 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7949 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7950 CvFLAGS(dstr) = CvFLAGS(sstr);
7953 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7957 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7964 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7969 return (PERL_CONTEXT*)NULL;
7971 /* look for it in the table first */
7972 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7976 /* create anew and remember what it is */
7977 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7978 ptr_table_store(PL_ptr_table, cxs, ncxs);
7981 PERL_CONTEXT *cx = &cxs[ix];
7982 PERL_CONTEXT *ncx = &ncxs[ix];
7983 ncx->cx_type = cx->cx_type;
7984 if (CxTYPE(cx) == CXt_SUBST) {
7985 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7988 ncx->blk_oldsp = cx->blk_oldsp;
7989 ncx->blk_oldcop = cx->blk_oldcop;
7990 ncx->blk_oldretsp = cx->blk_oldretsp;
7991 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7992 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7993 ncx->blk_oldpm = cx->blk_oldpm;
7994 ncx->blk_gimme = cx->blk_gimme;
7995 switch (CxTYPE(cx)) {
7997 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7998 ? cv_dup_inc(cx->blk_sub.cv)
7999 : cv_dup(cx->blk_sub.cv));
8000 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8001 ? av_dup_inc(cx->blk_sub.argarray)
8003 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
8004 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8005 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8006 ncx->blk_sub.lval = cx->blk_sub.lval;
8009 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8010 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8011 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8012 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8013 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8016 ncx->blk_loop.label = cx->blk_loop.label;
8017 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8018 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8019 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8020 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8021 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8022 ? cx->blk_loop.iterdata
8023 : gv_dup((GV*)cx->blk_loop.iterdata));
8024 ncx->blk_loop.oldcurpad
8025 = (SV**)ptr_table_fetch(PL_ptr_table,
8026 cx->blk_loop.oldcurpad);
8027 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8028 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8029 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8030 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8031 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8034 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8035 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8036 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8037 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8050 Perl_si_dup(pTHX_ PERL_SI *si)
8055 return (PERL_SI*)NULL;
8057 /* look for it in the table first */
8058 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8062 /* create anew and remember what it is */
8063 Newz(56, nsi, 1, PERL_SI);
8064 ptr_table_store(PL_ptr_table, si, nsi);
8066 nsi->si_stack = av_dup_inc(si->si_stack);
8067 nsi->si_cxix = si->si_cxix;
8068 nsi->si_cxmax = si->si_cxmax;
8069 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8070 nsi->si_type = si->si_type;
8071 nsi->si_prev = si_dup(si->si_prev);
8072 nsi->si_next = si_dup(si->si_next);
8073 nsi->si_markoff = si->si_markoff;
8078 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8079 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8080 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8081 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8082 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8083 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8084 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8085 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8086 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8087 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8088 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8089 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8092 #define pv_dup_inc(p) SAVEPV(p)
8093 #define pv_dup(p) SAVEPV(p)
8094 #define svp_dup_inc(p,pp) any_dup(p,pp)
8097 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8104 /* look for it in the table first */
8105 ret = ptr_table_fetch(PL_ptr_table, v);
8109 /* see if it is part of the interpreter structure */
8110 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8111 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8119 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8121 ANY *ss = proto_perl->Tsavestack;
8122 I32 ix = proto_perl->Tsavestack_ix;
8123 I32 max = proto_perl->Tsavestack_max;
8136 void (*dptr) (void*);
8137 void (*dxptr) (pTHXo_ void*);
8140 Newz(54, nss, max, ANY);
8146 case SAVEt_ITEM: /* normal string */
8147 sv = (SV*)POPPTR(ss,ix);
8148 TOPPTR(nss,ix) = sv_dup_inc(sv);
8149 sv = (SV*)POPPTR(ss,ix);
8150 TOPPTR(nss,ix) = sv_dup_inc(sv);
8152 case SAVEt_SV: /* scalar reference */
8153 sv = (SV*)POPPTR(ss,ix);
8154 TOPPTR(nss,ix) = sv_dup_inc(sv);
8155 gv = (GV*)POPPTR(ss,ix);
8156 TOPPTR(nss,ix) = gv_dup_inc(gv);
8158 case SAVEt_GENERIC_PVREF: /* generic char* */
8159 c = (char*)POPPTR(ss,ix);
8160 TOPPTR(nss,ix) = pv_dup(c);
8161 ptr = POPPTR(ss,ix);
8162 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8164 case SAVEt_GENERIC_SVREF: /* generic sv */
8165 case SAVEt_SVREF: /* scalar reference */
8166 sv = (SV*)POPPTR(ss,ix);
8167 TOPPTR(nss,ix) = sv_dup_inc(sv);
8168 ptr = POPPTR(ss,ix);
8169 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8171 case SAVEt_AV: /* array reference */
8172 av = (AV*)POPPTR(ss,ix);
8173 TOPPTR(nss,ix) = av_dup_inc(av);
8174 gv = (GV*)POPPTR(ss,ix);
8175 TOPPTR(nss,ix) = gv_dup(gv);
8177 case SAVEt_HV: /* hash reference */
8178 hv = (HV*)POPPTR(ss,ix);
8179 TOPPTR(nss,ix) = hv_dup_inc(hv);
8180 gv = (GV*)POPPTR(ss,ix);
8181 TOPPTR(nss,ix) = gv_dup(gv);
8183 case SAVEt_INT: /* int reference */
8184 ptr = POPPTR(ss,ix);
8185 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8186 intval = (int)POPINT(ss,ix);
8187 TOPINT(nss,ix) = intval;
8189 case SAVEt_LONG: /* long reference */
8190 ptr = POPPTR(ss,ix);
8191 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8192 longval = (long)POPLONG(ss,ix);
8193 TOPLONG(nss,ix) = longval;
8195 case SAVEt_I32: /* I32 reference */
8196 case SAVEt_I16: /* I16 reference */
8197 case SAVEt_I8: /* I8 reference */
8198 ptr = POPPTR(ss,ix);
8199 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8203 case SAVEt_IV: /* IV reference */
8204 ptr = POPPTR(ss,ix);
8205 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8209 case SAVEt_SPTR: /* SV* reference */
8210 ptr = POPPTR(ss,ix);
8211 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8212 sv = (SV*)POPPTR(ss,ix);
8213 TOPPTR(nss,ix) = sv_dup(sv);
8215 case SAVEt_VPTR: /* random* reference */
8216 ptr = POPPTR(ss,ix);
8217 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8218 ptr = POPPTR(ss,ix);
8219 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8221 case SAVEt_PPTR: /* char* reference */
8222 ptr = POPPTR(ss,ix);
8223 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8224 c = (char*)POPPTR(ss,ix);
8225 TOPPTR(nss,ix) = pv_dup(c);
8227 case SAVEt_HPTR: /* HV* reference */
8228 ptr = POPPTR(ss,ix);
8229 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8230 hv = (HV*)POPPTR(ss,ix);
8231 TOPPTR(nss,ix) = hv_dup(hv);
8233 case SAVEt_APTR: /* AV* reference */
8234 ptr = POPPTR(ss,ix);
8235 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8236 av = (AV*)POPPTR(ss,ix);
8237 TOPPTR(nss,ix) = av_dup(av);
8240 gv = (GV*)POPPTR(ss,ix);
8241 TOPPTR(nss,ix) = gv_dup(gv);
8243 case SAVEt_GP: /* scalar reference */
8244 gp = (GP*)POPPTR(ss,ix);
8245 TOPPTR(nss,ix) = gp = gp_dup(gp);
8246 (void)GpREFCNT_inc(gp);
8247 gv = (GV*)POPPTR(ss,ix);
8248 TOPPTR(nss,ix) = gv_dup_inc(c);
8249 c = (char*)POPPTR(ss,ix);
8250 TOPPTR(nss,ix) = pv_dup(c);
8257 sv = (SV*)POPPTR(ss,ix);
8258 TOPPTR(nss,ix) = sv_dup_inc(sv);
8261 ptr = POPPTR(ss,ix);
8262 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8263 /* these are assumed to be refcounted properly */
8264 switch (((OP*)ptr)->op_type) {
8271 TOPPTR(nss,ix) = ptr;
8276 TOPPTR(nss,ix) = Nullop;
8281 TOPPTR(nss,ix) = Nullop;
8284 c = (char*)POPPTR(ss,ix);
8285 TOPPTR(nss,ix) = pv_dup_inc(c);
8288 longval = POPLONG(ss,ix);
8289 TOPLONG(nss,ix) = longval;
8292 hv = (HV*)POPPTR(ss,ix);
8293 TOPPTR(nss,ix) = hv_dup_inc(hv);
8294 c = (char*)POPPTR(ss,ix);
8295 TOPPTR(nss,ix) = pv_dup_inc(c);
8299 case SAVEt_DESTRUCTOR:
8300 ptr = POPPTR(ss,ix);
8301 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8302 dptr = POPDPTR(ss,ix);
8303 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8305 case SAVEt_DESTRUCTOR_X:
8306 ptr = POPPTR(ss,ix);
8307 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8308 dxptr = POPDXPTR(ss,ix);
8309 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8311 case SAVEt_REGCONTEXT:
8317 case SAVEt_STACK_POS: /* Position on Perl stack */
8321 case SAVEt_AELEM: /* array element */
8322 sv = (SV*)POPPTR(ss,ix);
8323 TOPPTR(nss,ix) = sv_dup_inc(sv);
8326 av = (AV*)POPPTR(ss,ix);
8327 TOPPTR(nss,ix) = av_dup_inc(av);
8329 case SAVEt_HELEM: /* hash element */
8330 sv = (SV*)POPPTR(ss,ix);
8331 TOPPTR(nss,ix) = sv_dup_inc(sv);
8332 sv = (SV*)POPPTR(ss,ix);
8333 TOPPTR(nss,ix) = sv_dup_inc(sv);
8334 hv = (HV*)POPPTR(ss,ix);
8335 TOPPTR(nss,ix) = hv_dup_inc(hv);
8338 ptr = POPPTR(ss,ix);
8339 TOPPTR(nss,ix) = ptr;
8346 av = (AV*)POPPTR(ss,ix);
8347 TOPPTR(nss,ix) = av_dup(av);
8350 longval = (long)POPLONG(ss,ix);
8351 TOPLONG(nss,ix) = longval;
8352 ptr = POPPTR(ss,ix);
8353 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8354 sv = (SV*)POPPTR(ss,ix);
8355 TOPPTR(nss,ix) = sv_dup(sv);
8358 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8370 perl_clone(PerlInterpreter *proto_perl, UV flags)
8373 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8376 #ifdef PERL_IMPLICIT_SYS
8377 return perl_clone_using(proto_perl, flags,
8379 proto_perl->IMemShared,
8380 proto_perl->IMemParse,
8390 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8391 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8392 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8393 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8394 struct IPerlDir* ipD, struct IPerlSock* ipS,
8395 struct IPerlProc* ipP)
8397 /* XXX many of the string copies here can be optimized if they're
8398 * constants; they need to be allocated as common memory and just
8399 * their pointers copied. */
8403 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8405 PERL_SET_THX(pPerl);
8406 # else /* !PERL_OBJECT */
8407 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8408 PERL_SET_THX(my_perl);
8411 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8416 # else /* !DEBUGGING */
8417 Zero(my_perl, 1, PerlInterpreter);
8418 # endif /* DEBUGGING */
8422 PL_MemShared = ipMS;
8430 # endif /* PERL_OBJECT */
8431 #else /* !PERL_IMPLICIT_SYS */
8433 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8434 PERL_SET_THX(my_perl);
8437 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8442 # else /* !DEBUGGING */
8443 Zero(my_perl, 1, PerlInterpreter);
8444 # endif /* DEBUGGING */
8445 #endif /* PERL_IMPLICIT_SYS */
8448 PL_xiv_arenaroot = NULL;
8450 PL_xnv_arenaroot = NULL;
8452 PL_xrv_arenaroot = NULL;
8454 PL_xpv_arenaroot = NULL;
8456 PL_xpviv_arenaroot = NULL;
8457 PL_xpviv_root = NULL;
8458 PL_xpvnv_arenaroot = NULL;
8459 PL_xpvnv_root = NULL;
8460 PL_xpvcv_arenaroot = NULL;
8461 PL_xpvcv_root = NULL;
8462 PL_xpvav_arenaroot = NULL;
8463 PL_xpvav_root = NULL;
8464 PL_xpvhv_arenaroot = NULL;
8465 PL_xpvhv_root = NULL;
8466 PL_xpvmg_arenaroot = NULL;
8467 PL_xpvmg_root = NULL;
8468 PL_xpvlv_arenaroot = NULL;
8469 PL_xpvlv_root = NULL;
8470 PL_xpvbm_arenaroot = NULL;
8471 PL_xpvbm_root = NULL;
8472 PL_he_arenaroot = NULL;
8474 PL_nice_chunk = NULL;
8475 PL_nice_chunk_size = 0;
8478 PL_sv_root = Nullsv;
8479 PL_sv_arenaroot = Nullsv;
8481 PL_debug = proto_perl->Idebug;
8483 /* create SV map for pointer relocation */
8484 PL_ptr_table = ptr_table_new();
8486 /* initialize these special pointers as early as possible */
8487 SvANY(&PL_sv_undef) = NULL;
8488 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8489 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8490 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8493 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8495 SvANY(&PL_sv_no) = new_XPVNV();
8497 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8498 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8499 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8500 SvCUR(&PL_sv_no) = 0;
8501 SvLEN(&PL_sv_no) = 1;
8502 SvNVX(&PL_sv_no) = 0;
8503 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8506 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8508 SvANY(&PL_sv_yes) = new_XPVNV();
8510 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8511 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8512 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8513 SvCUR(&PL_sv_yes) = 1;
8514 SvLEN(&PL_sv_yes) = 2;
8515 SvNVX(&PL_sv_yes) = 1;
8516 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8518 /* create shared string table */
8519 PL_strtab = newHV();
8520 HvSHAREKEYS_off(PL_strtab);
8521 hv_ksplit(PL_strtab, 512);
8522 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8524 PL_compiling = proto_perl->Icompiling;
8525 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8526 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8527 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8528 if (!specialWARN(PL_compiling.cop_warnings))
8529 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8530 if (!specialCopIO(PL_compiling.cop_io))
8531 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8532 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8534 /* pseudo environmental stuff */
8535 PL_origargc = proto_perl->Iorigargc;
8537 New(0, PL_origargv, i+1, char*);
8538 PL_origargv[i] = '\0';
8540 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8542 PL_envgv = gv_dup(proto_perl->Ienvgv);
8543 PL_incgv = gv_dup(proto_perl->Iincgv);
8544 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8545 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8546 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8547 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8550 PL_minus_c = proto_perl->Iminus_c;
8551 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8552 PL_localpatches = proto_perl->Ilocalpatches;
8553 PL_splitstr = proto_perl->Isplitstr;
8554 PL_preprocess = proto_perl->Ipreprocess;
8555 PL_minus_n = proto_perl->Iminus_n;
8556 PL_minus_p = proto_perl->Iminus_p;
8557 PL_minus_l = proto_perl->Iminus_l;
8558 PL_minus_a = proto_perl->Iminus_a;
8559 PL_minus_F = proto_perl->Iminus_F;
8560 PL_doswitches = proto_perl->Idoswitches;
8561 PL_dowarn = proto_perl->Idowarn;
8562 PL_doextract = proto_perl->Idoextract;
8563 PL_sawampersand = proto_perl->Isawampersand;
8564 PL_unsafe = proto_perl->Iunsafe;
8565 PL_inplace = SAVEPV(proto_perl->Iinplace);
8566 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8567 PL_perldb = proto_perl->Iperldb;
8568 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8570 /* magical thingies */
8571 /* XXX time(&PL_basetime) when asked for? */
8572 PL_basetime = proto_perl->Ibasetime;
8573 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8575 PL_maxsysfd = proto_perl->Imaxsysfd;
8576 PL_multiline = proto_perl->Imultiline;
8577 PL_statusvalue = proto_perl->Istatusvalue;
8579 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8582 /* shortcuts to various I/O objects */
8583 PL_stdingv = gv_dup(proto_perl->Istdingv);
8584 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8585 PL_defgv = gv_dup(proto_perl->Idefgv);
8586 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8587 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8588 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8590 /* shortcuts to regexp stuff */
8591 PL_replgv = gv_dup(proto_perl->Ireplgv);
8593 /* shortcuts to misc objects */
8594 PL_errgv = gv_dup(proto_perl->Ierrgv);
8596 /* shortcuts to debugging objects */
8597 PL_DBgv = gv_dup(proto_perl->IDBgv);
8598 PL_DBline = gv_dup(proto_perl->IDBline);
8599 PL_DBsub = gv_dup(proto_perl->IDBsub);
8600 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8601 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8602 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8603 PL_lineary = av_dup(proto_perl->Ilineary);
8604 PL_dbargs = av_dup(proto_perl->Idbargs);
8607 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8608 PL_curstash = hv_dup(proto_perl->Tcurstash);
8609 PL_debstash = hv_dup(proto_perl->Idebstash);
8610 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8611 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8613 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8614 PL_endav = av_dup_inc(proto_perl->Iendav);
8615 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8616 PL_initav = av_dup_inc(proto_perl->Iinitav);
8618 PL_sub_generation = proto_perl->Isub_generation;
8620 /* funky return mechanisms */
8621 PL_forkprocess = proto_perl->Iforkprocess;
8623 /* subprocess state */
8624 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8626 /* internal state */
8627 PL_tainting = proto_perl->Itainting;
8628 PL_maxo = proto_perl->Imaxo;
8629 if (proto_perl->Iop_mask)
8630 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8632 PL_op_mask = Nullch;
8634 /* current interpreter roots */
8635 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8636 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8637 PL_main_start = proto_perl->Imain_start;
8638 PL_eval_root = proto_perl->Ieval_root;
8639 PL_eval_start = proto_perl->Ieval_start;
8641 /* runtime control stuff */
8642 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8643 PL_copline = proto_perl->Icopline;
8645 PL_filemode = proto_perl->Ifilemode;
8646 PL_lastfd = proto_perl->Ilastfd;
8647 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8650 PL_gensym = proto_perl->Igensym;
8651 PL_preambled = proto_perl->Ipreambled;
8652 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8653 PL_laststatval = proto_perl->Ilaststatval;
8654 PL_laststype = proto_perl->Ilaststype;
8655 PL_mess_sv = Nullsv;
8657 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8658 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8660 /* interpreter atexit processing */
8661 PL_exitlistlen = proto_perl->Iexitlistlen;
8662 if (PL_exitlistlen) {
8663 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8664 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8667 PL_exitlist = (PerlExitListEntry*)NULL;
8668 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8670 PL_profiledata = NULL;
8671 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8672 /* PL_rsfp_filters entries have fake IoDIRP() */
8673 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8675 PL_compcv = cv_dup(proto_perl->Icompcv);
8676 PL_comppad = av_dup(proto_perl->Icomppad);
8677 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8678 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8679 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8680 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8681 proto_perl->Tcurpad);
8683 #ifdef HAVE_INTERP_INTERN
8684 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8687 /* more statics moved here */
8688 PL_generation = proto_perl->Igeneration;
8689 PL_DBcv = cv_dup(proto_perl->IDBcv);
8691 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8692 PL_in_clean_all = proto_perl->Iin_clean_all;
8694 PL_uid = proto_perl->Iuid;
8695 PL_euid = proto_perl->Ieuid;
8696 PL_gid = proto_perl->Igid;
8697 PL_egid = proto_perl->Iegid;
8698 PL_nomemok = proto_perl->Inomemok;
8699 PL_an = proto_perl->Ian;
8700 PL_cop_seqmax = proto_perl->Icop_seqmax;
8701 PL_op_seqmax = proto_perl->Iop_seqmax;
8702 PL_evalseq = proto_perl->Ievalseq;
8703 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8704 PL_origalen = proto_perl->Iorigalen;
8705 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8706 PL_osname = SAVEPV(proto_perl->Iosname);
8707 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8708 PL_sighandlerp = proto_perl->Isighandlerp;
8711 PL_runops = proto_perl->Irunops;
8713 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8716 PL_cshlen = proto_perl->Icshlen;
8717 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8720 PL_lex_state = proto_perl->Ilex_state;
8721 PL_lex_defer = proto_perl->Ilex_defer;
8722 PL_lex_expect = proto_perl->Ilex_expect;
8723 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8724 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8725 PL_lex_starts = proto_perl->Ilex_starts;
8726 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8727 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8728 PL_lex_op = proto_perl->Ilex_op;
8729 PL_lex_inpat = proto_perl->Ilex_inpat;
8730 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8731 PL_lex_brackets = proto_perl->Ilex_brackets;
8732 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8733 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8734 PL_lex_casemods = proto_perl->Ilex_casemods;
8735 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8736 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8738 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8739 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8740 PL_nexttoke = proto_perl->Inexttoke;
8742 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8743 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8744 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8745 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8746 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8747 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8748 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8749 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8750 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8751 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8752 PL_pending_ident = proto_perl->Ipending_ident;
8753 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8755 PL_expect = proto_perl->Iexpect;
8757 PL_multi_start = proto_perl->Imulti_start;
8758 PL_multi_end = proto_perl->Imulti_end;
8759 PL_multi_open = proto_perl->Imulti_open;
8760 PL_multi_close = proto_perl->Imulti_close;
8762 PL_error_count = proto_perl->Ierror_count;
8763 PL_subline = proto_perl->Isubline;
8764 PL_subname = sv_dup_inc(proto_perl->Isubname);
8766 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8767 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8768 PL_padix = proto_perl->Ipadix;
8769 PL_padix_floor = proto_perl->Ipadix_floor;
8770 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8772 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8773 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8774 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8775 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8776 PL_last_lop_op = proto_perl->Ilast_lop_op;
8777 PL_in_my = proto_perl->Iin_my;
8778 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8780 PL_cryptseen = proto_perl->Icryptseen;
8783 PL_hints = proto_perl->Ihints;
8785 PL_amagic_generation = proto_perl->Iamagic_generation;
8787 #ifdef USE_LOCALE_COLLATE
8788 PL_collation_ix = proto_perl->Icollation_ix;
8789 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8790 PL_collation_standard = proto_perl->Icollation_standard;
8791 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8792 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8793 #endif /* USE_LOCALE_COLLATE */
8795 #ifdef USE_LOCALE_NUMERIC
8796 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8797 PL_numeric_standard = proto_perl->Inumeric_standard;
8798 PL_numeric_local = proto_perl->Inumeric_local;
8799 PL_numeric_radix = proto_perl->Inumeric_radix;
8800 #endif /* !USE_LOCALE_NUMERIC */
8802 /* utf8 character classes */
8803 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8804 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8805 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8806 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8807 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8808 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8809 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8810 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8811 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8812 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8813 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8814 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8815 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8816 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8817 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8818 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8819 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8822 PL_last_swash_hv = Nullhv; /* reinits on demand */
8823 PL_last_swash_klen = 0;
8824 PL_last_swash_key[0]= '\0';
8825 PL_last_swash_tmps = (U8*)NULL;
8826 PL_last_swash_slen = 0;
8828 /* perly.c globals */
8829 PL_yydebug = proto_perl->Iyydebug;
8830 PL_yynerrs = proto_perl->Iyynerrs;
8831 PL_yyerrflag = proto_perl->Iyyerrflag;
8832 PL_yychar = proto_perl->Iyychar;
8833 PL_yyval = proto_perl->Iyyval;
8834 PL_yylval = proto_perl->Iyylval;
8836 PL_glob_index = proto_perl->Iglob_index;
8837 PL_srand_called = proto_perl->Isrand_called;
8838 PL_uudmap['M'] = 0; /* reinits on demand */
8839 PL_bitcount = Nullch; /* reinits on demand */
8841 if (proto_perl->Ipsig_ptr) {
8842 int sig_num[] = { SIG_NUM };
8843 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8844 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8845 for (i = 1; PL_sig_name[i]; i++) {
8846 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8847 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8851 PL_psig_ptr = (SV**)NULL;
8852 PL_psig_name = (SV**)NULL;
8855 /* thrdvar.h stuff */
8858 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8859 PL_tmps_ix = proto_perl->Ttmps_ix;
8860 PL_tmps_max = proto_perl->Ttmps_max;
8861 PL_tmps_floor = proto_perl->Ttmps_floor;
8862 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8864 while (i <= PL_tmps_ix) {
8865 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8869 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8870 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8871 Newz(54, PL_markstack, i, I32);
8872 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8873 - proto_perl->Tmarkstack);
8874 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8875 - proto_perl->Tmarkstack);
8876 Copy(proto_perl->Tmarkstack, PL_markstack,
8877 PL_markstack_ptr - PL_markstack + 1, I32);
8879 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8880 * NOTE: unlike the others! */
8881 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8882 PL_scopestack_max = proto_perl->Tscopestack_max;
8883 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8884 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8886 /* next push_return() sets PL_retstack[PL_retstack_ix]
8887 * NOTE: unlike the others! */
8888 PL_retstack_ix = proto_perl->Tretstack_ix;
8889 PL_retstack_max = proto_perl->Tretstack_max;
8890 Newz(54, PL_retstack, PL_retstack_max, OP*);
8891 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8893 /* NOTE: si_dup() looks at PL_markstack */
8894 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8896 /* PL_curstack = PL_curstackinfo->si_stack; */
8897 PL_curstack = av_dup(proto_perl->Tcurstack);
8898 PL_mainstack = av_dup(proto_perl->Tmainstack);
8900 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8901 PL_stack_base = AvARRAY(PL_curstack);
8902 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8903 - proto_perl->Tstack_base);
8904 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8906 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8907 * NOTE: unlike the others! */
8908 PL_savestack_ix = proto_perl->Tsavestack_ix;
8909 PL_savestack_max = proto_perl->Tsavestack_max;
8910 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8911 PL_savestack = ss_dup(proto_perl);
8915 ENTER; /* perl_destruct() wants to LEAVE; */
8918 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8919 PL_top_env = &PL_start_env;
8921 PL_op = proto_perl->Top;
8924 PL_Xpv = (XPV*)NULL;
8925 PL_na = proto_perl->Tna;
8927 PL_statbuf = proto_perl->Tstatbuf;
8928 PL_statcache = proto_perl->Tstatcache;
8929 PL_statgv = gv_dup(proto_perl->Tstatgv);
8930 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8932 PL_timesbuf = proto_perl->Ttimesbuf;
8935 PL_tainted = proto_perl->Ttainted;
8936 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8937 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8938 PL_rs = sv_dup_inc(proto_perl->Trs);
8939 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8940 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
8941 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8942 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8943 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8944 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8945 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8947 PL_restartop = proto_perl->Trestartop;
8948 PL_in_eval = proto_perl->Tin_eval;
8949 PL_delaymagic = proto_perl->Tdelaymagic;
8950 PL_dirty = proto_perl->Tdirty;
8951 PL_localizing = proto_perl->Tlocalizing;
8953 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8954 PL_protect = proto_perl->Tprotect;
8956 PL_errors = sv_dup_inc(proto_perl->Terrors);
8957 PL_av_fetch_sv = Nullsv;
8958 PL_hv_fetch_sv = Nullsv;
8959 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8960 PL_modcount = proto_perl->Tmodcount;
8961 PL_lastgotoprobe = Nullop;
8962 PL_dumpindent = proto_perl->Tdumpindent;
8964 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8965 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8966 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8967 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8968 PL_sortcxix = proto_perl->Tsortcxix;
8969 PL_efloatbuf = Nullch; /* reinits on demand */
8970 PL_efloatsize = 0; /* reinits on demand */
8974 PL_screamfirst = NULL;
8975 PL_screamnext = NULL;
8976 PL_maxscream = -1; /* reinits on demand */
8977 PL_lastscream = Nullsv;
8979 PL_watchaddr = NULL;
8980 PL_watchok = Nullch;
8982 PL_regdummy = proto_perl->Tregdummy;
8983 PL_regcomp_parse = Nullch;
8984 PL_regxend = Nullch;
8985 PL_regcode = (regnode*)NULL;
8988 PL_regprecomp = Nullch;
8993 PL_seen_zerolen = 0;
8995 PL_regcomp_rx = (regexp*)NULL;
8997 PL_colorset = 0; /* reinits PL_colors[] */
8998 /*PL_colors[6] = {0,0,0,0,0,0};*/
8999 PL_reg_whilem_seen = 0;
9000 PL_reginput = Nullch;
9003 PL_regstartp = (I32*)NULL;
9004 PL_regendp = (I32*)NULL;
9005 PL_reglastparen = (U32*)NULL;
9006 PL_regtill = Nullch;
9008 PL_reg_start_tmp = (char**)NULL;
9009 PL_reg_start_tmpl = 0;
9010 PL_regdata = (struct reg_data*)NULL;
9013 PL_reg_eval_set = 0;
9015 PL_regprogram = (regnode*)NULL;
9017 PL_regcc = (CURCUR*)NULL;
9018 PL_reg_call_cc = (struct re_cc_state*)NULL;
9019 PL_reg_re = (regexp*)NULL;
9020 PL_reg_ganch = Nullch;
9022 PL_reg_magic = (MAGIC*)NULL;
9024 PL_reg_oldcurpm = (PMOP*)NULL;
9025 PL_reg_curpm = (PMOP*)NULL;
9026 PL_reg_oldsaved = Nullch;
9027 PL_reg_oldsavedlen = 0;
9029 PL_reg_leftiter = 0;
9030 PL_reg_poscache = Nullch;
9031 PL_reg_poscache_size= 0;
9033 /* RE engine - function pointers */
9034 PL_regcompp = proto_perl->Tregcompp;
9035 PL_regexecp = proto_perl->Tregexecp;
9036 PL_regint_start = proto_perl->Tregint_start;
9037 PL_regint_string = proto_perl->Tregint_string;
9038 PL_regfree = proto_perl->Tregfree;
9040 PL_reginterp_cnt = 0;
9041 PL_reg_starttry = 0;
9044 return (PerlInterpreter*)pPerl;
9050 #else /* !USE_ITHREADS */
9056 #endif /* USE_ITHREADS */
9059 do_report_used(pTHXo_ SV *sv)
9061 if (SvTYPE(sv) != SVTYPEMASK) {
9062 PerlIO_printf(Perl_debug_log, "****\n");
9068 do_clean_objs(pTHXo_ SV *sv)
9072 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9073 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9074 if (SvWEAKREF(sv)) {
9085 /* XXX Might want to check arrays, etc. */
9088 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9090 do_clean_named_objs(pTHXo_ SV *sv)
9092 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9093 if ( SvOBJECT(GvSV(sv)) ||
9094 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9095 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9096 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9097 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9099 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9107 do_clean_all(pTHXo_ SV *sv)
9109 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9110 SvFLAGS(sv) |= SVf_BREAK;