3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
29 * "A time to plant, and a time to uproot what was planted..."
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
40 /* sv_mutex must be held while calling uproot_SV() */
41 #define uproot_SV(p) \
44 PL_sv_root = (SV*)SvANY(p); \
66 if (PL_debug & 32768) \
76 if (PL_debug & 32768) {
81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
83 svend = &sva[SvREFCNT(sva)];
84 if (p >= sv && p < svend)
88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
90 "Attempt to free non-arena SV: 0x%"UVxf,
98 #else /* ! DEBUGGING */
100 #define del_SV(p) plant_SV(p)
102 #endif /* DEBUGGING */
105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
110 Zero(ptr, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
197 XPV *arena, *arenanext;
199 /* Free arenas here, but be careful about fake ones. (We assume
200 contiguity of the fake ones with the corresponding real ones.) */
202 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
203 svanext = (SV*) SvANY(sva);
204 while (svanext && SvFAKE(svanext))
205 svanext = (SV*) SvANY(svanext);
208 Safefree((void *)sva);
211 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
212 arenanext = (XPV*)arena->xpv_pv;
215 PL_xiv_arenaroot = 0;
217 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
218 arenanext = (XPV*)arena->xpv_pv;
221 PL_xnv_arenaroot = 0;
223 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
224 arenanext = (XPV*)arena->xpv_pv;
227 PL_xrv_arenaroot = 0;
229 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
230 arenanext = (XPV*)arena->xpv_pv;
233 PL_xpv_arenaroot = 0;
235 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
236 arenanext = (XPV*)arena->xpv_pv;
239 PL_xpviv_arenaroot = 0;
241 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
242 arenanext = (XPV*)arena->xpv_pv;
245 PL_xpvnv_arenaroot = 0;
247 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
248 arenanext = (XPV*)arena->xpv_pv;
251 PL_xpvcv_arenaroot = 0;
253 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
254 arenanext = (XPV*)arena->xpv_pv;
257 PL_xpvav_arenaroot = 0;
259 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
260 arenanext = (XPV*)arena->xpv_pv;
263 PL_xpvhv_arenaroot = 0;
265 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
266 arenanext = (XPV*)arena->xpv_pv;
269 PL_xpvmg_arenaroot = 0;
271 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
272 arenanext = (XPV*)arena->xpv_pv;
275 PL_xpvlv_arenaroot = 0;
277 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
278 arenanext = (XPV*)arena->xpv_pv;
281 PL_xpvbm_arenaroot = 0;
283 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
284 arenanext = (XPV*)arena->xpv_pv;
290 Safefree(PL_nice_chunk);
291 PL_nice_chunk = Nullch;
292 PL_nice_chunk_size = 0;
298 Perl_report_uninit(pTHX)
301 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
302 " in ", PL_op_desc[PL_op->op_type]);
304 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
316 * See comment in more_xiv() -- RAM.
318 PL_xiv_root = *(IV**)xiv;
320 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
324 S_del_xiv(pTHX_ XPVIV *p)
326 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
328 *(IV**)xiv = PL_xiv_root;
339 New(705, ptr, 1008/sizeof(XPV), XPV);
340 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
341 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
344 xivend = &xiv[1008 / sizeof(IV) - 1];
345 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
347 while (xiv < xivend) {
348 *(IV**)xiv = (IV *)(xiv + 1);
362 PL_xnv_root = *(NV**)xnv;
364 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
368 S_del_xnv(pTHX_ XPVNV *p)
370 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
372 *(NV**)xnv = PL_xnv_root;
383 New(711, ptr, 1008/sizeof(XPV), XPV);
384 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
385 PL_xnv_arenaroot = ptr;
388 xnvend = &xnv[1008 / sizeof(NV) - 1];
389 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
391 while (xnv < xnvend) {
392 *(NV**)xnv = (NV*)(xnv + 1);
406 PL_xrv_root = (XRV*)xrv->xrv_rv;
412 S_del_xrv(pTHX_ XRV *p)
415 p->xrv_rv = (SV*)PL_xrv_root;
424 register XRV* xrvend;
426 New(712, ptr, 1008/sizeof(XPV), XPV);
427 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
428 PL_xrv_arenaroot = ptr;
431 xrvend = &xrv[1008 / sizeof(XRV) - 1];
432 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
434 while (xrv < xrvend) {
435 xrv->xrv_rv = (SV*)(xrv + 1);
449 PL_xpv_root = (XPV*)xpv->xpv_pv;
455 S_del_xpv(pTHX_ XPV *p)
458 p->xpv_pv = (char*)PL_xpv_root;
467 register XPV* xpvend;
468 New(713, xpv, 1008/sizeof(XPV), XPV);
469 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
470 PL_xpv_arenaroot = xpv;
472 xpvend = &xpv[1008 / sizeof(XPV) - 1];
474 while (xpv < xpvend) {
475 xpv->xpv_pv = (char*)(xpv + 1);
488 xpviv = PL_xpviv_root;
489 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
495 S_del_xpviv(pTHX_ XPVIV *p)
498 p->xpv_pv = (char*)PL_xpviv_root;
506 register XPVIV* xpviv;
507 register XPVIV* xpvivend;
508 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
509 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
510 PL_xpviv_arenaroot = xpviv;
512 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
513 PL_xpviv_root = ++xpviv;
514 while (xpviv < xpvivend) {
515 xpviv->xpv_pv = (char*)(xpviv + 1);
528 xpvnv = PL_xpvnv_root;
529 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
535 S_del_xpvnv(pTHX_ XPVNV *p)
538 p->xpv_pv = (char*)PL_xpvnv_root;
546 register XPVNV* xpvnv;
547 register XPVNV* xpvnvend;
548 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
549 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
550 PL_xpvnv_arenaroot = xpvnv;
552 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
553 PL_xpvnv_root = ++xpvnv;
554 while (xpvnv < xpvnvend) {
555 xpvnv->xpv_pv = (char*)(xpvnv + 1);
568 xpvcv = PL_xpvcv_root;
569 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
575 S_del_xpvcv(pTHX_ XPVCV *p)
578 p->xpv_pv = (char*)PL_xpvcv_root;
586 register XPVCV* xpvcv;
587 register XPVCV* xpvcvend;
588 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
589 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
590 PL_xpvcv_arenaroot = xpvcv;
592 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
593 PL_xpvcv_root = ++xpvcv;
594 while (xpvcv < xpvcvend) {
595 xpvcv->xpv_pv = (char*)(xpvcv + 1);
608 xpvav = PL_xpvav_root;
609 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
615 S_del_xpvav(pTHX_ XPVAV *p)
618 p->xav_array = (char*)PL_xpvav_root;
626 register XPVAV* xpvav;
627 register XPVAV* xpvavend;
628 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
629 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
630 PL_xpvav_arenaroot = xpvav;
632 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
633 PL_xpvav_root = ++xpvav;
634 while (xpvav < xpvavend) {
635 xpvav->xav_array = (char*)(xpvav + 1);
638 xpvav->xav_array = 0;
648 xpvhv = PL_xpvhv_root;
649 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
655 S_del_xpvhv(pTHX_ XPVHV *p)
658 p->xhv_array = (char*)PL_xpvhv_root;
666 register XPVHV* xpvhv;
667 register XPVHV* xpvhvend;
668 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
669 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
670 PL_xpvhv_arenaroot = xpvhv;
672 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
673 PL_xpvhv_root = ++xpvhv;
674 while (xpvhv < xpvhvend) {
675 xpvhv->xhv_array = (char*)(xpvhv + 1);
678 xpvhv->xhv_array = 0;
688 xpvmg = PL_xpvmg_root;
689 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
695 S_del_xpvmg(pTHX_ XPVMG *p)
698 p->xpv_pv = (char*)PL_xpvmg_root;
706 register XPVMG* xpvmg;
707 register XPVMG* xpvmgend;
708 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
709 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
710 PL_xpvmg_arenaroot = xpvmg;
712 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
713 PL_xpvmg_root = ++xpvmg;
714 while (xpvmg < xpvmgend) {
715 xpvmg->xpv_pv = (char*)(xpvmg + 1);
728 xpvlv = PL_xpvlv_root;
729 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
735 S_del_xpvlv(pTHX_ XPVLV *p)
738 p->xpv_pv = (char*)PL_xpvlv_root;
746 register XPVLV* xpvlv;
747 register XPVLV* xpvlvend;
748 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
749 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
750 PL_xpvlv_arenaroot = xpvlv;
752 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
753 PL_xpvlv_root = ++xpvlv;
754 while (xpvlv < xpvlvend) {
755 xpvlv->xpv_pv = (char*)(xpvlv + 1);
768 xpvbm = PL_xpvbm_root;
769 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
775 S_del_xpvbm(pTHX_ XPVBM *p)
778 p->xpv_pv = (char*)PL_xpvbm_root;
786 register XPVBM* xpvbm;
787 register XPVBM* xpvbmend;
788 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
789 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
790 PL_xpvbm_arenaroot = xpvbm;
792 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
793 PL_xpvbm_root = ++xpvbm;
794 while (xpvbm < xpvbmend) {
795 xpvbm->xpv_pv = (char*)(xpvbm + 1);
802 # define my_safemalloc(s) (void*)safexmalloc(717,s)
803 # define my_safefree(p) safexfree((char*)p)
805 # define my_safemalloc(s) (void*)safemalloc(s)
806 # define my_safefree(p) safefree((char*)p)
811 #define new_XIV() my_safemalloc(sizeof(XPVIV))
812 #define del_XIV(p) my_safefree(p)
814 #define new_XNV() my_safemalloc(sizeof(XPVNV))
815 #define del_XNV(p) my_safefree(p)
817 #define new_XRV() my_safemalloc(sizeof(XRV))
818 #define del_XRV(p) my_safefree(p)
820 #define new_XPV() my_safemalloc(sizeof(XPV))
821 #define del_XPV(p) my_safefree(p)
823 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
824 #define del_XPVIV(p) my_safefree(p)
826 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
827 #define del_XPVNV(p) my_safefree(p)
829 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
830 #define del_XPVCV(p) my_safefree(p)
832 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
833 #define del_XPVAV(p) my_safefree(p)
835 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
836 #define del_XPVHV(p) my_safefree(p)
838 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
839 #define del_XPVMG(p) my_safefree(p)
841 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
842 #define del_XPVLV(p) my_safefree(p)
844 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
845 #define del_XPVBM(p) my_safefree(p)
849 #define new_XIV() (void*)new_xiv()
850 #define del_XIV(p) del_xiv((XPVIV*) p)
852 #define new_XNV() (void*)new_xnv()
853 #define del_XNV(p) del_xnv((XPVNV*) p)
855 #define new_XRV() (void*)new_xrv()
856 #define del_XRV(p) del_xrv((XRV*) p)
858 #define new_XPV() (void*)new_xpv()
859 #define del_XPV(p) del_xpv((XPV *)p)
861 #define new_XPVIV() (void*)new_xpviv()
862 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
864 #define new_XPVNV() (void*)new_xpvnv()
865 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
867 #define new_XPVCV() (void*)new_xpvcv()
868 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
870 #define new_XPVAV() (void*)new_xpvav()
871 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
873 #define new_XPVHV() (void*)new_xpvhv()
874 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
876 #define new_XPVMG() (void*)new_xpvmg()
877 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
879 #define new_XPVLV() (void*)new_xpvlv()
880 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
882 #define new_XPVBM() (void*)new_xpvbm()
883 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
887 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
888 #define del_XPVGV(p) my_safefree(p)
890 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
891 #define del_XPVFM(p) my_safefree(p)
893 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
894 #define del_XPVIO(p) my_safefree(p)
897 =for apidoc sv_upgrade
899 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
906 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
916 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
920 if (SvTYPE(sv) == mt)
926 switch (SvTYPE(sv)) {
947 else if (mt < SVt_PVIV)
964 pv = (char*)SvRV(sv);
984 else if (mt == SVt_NV)
995 del_XPVIV(SvANY(sv));
1005 del_XPVNV(SvANY(sv));
1013 magic = SvMAGIC(sv);
1014 stash = SvSTASH(sv);
1015 del_XPVMG(SvANY(sv));
1018 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1023 Perl_croak(aTHX_ "Can't upgrade to undef");
1025 SvANY(sv) = new_XIV();
1029 SvANY(sv) = new_XNV();
1033 SvANY(sv) = new_XRV();
1037 SvANY(sv) = new_XPV();
1043 SvANY(sv) = new_XPVIV();
1053 SvANY(sv) = new_XPVNV();
1061 SvANY(sv) = new_XPVMG();
1067 SvMAGIC(sv) = magic;
1068 SvSTASH(sv) = stash;
1071 SvANY(sv) = new_XPVLV();
1077 SvMAGIC(sv) = magic;
1078 SvSTASH(sv) = stash;
1085 SvANY(sv) = new_XPVAV();
1093 SvMAGIC(sv) = magic;
1094 SvSTASH(sv) = stash;
1100 SvANY(sv) = new_XPVHV();
1108 SvMAGIC(sv) = magic;
1109 SvSTASH(sv) = stash;
1116 SvANY(sv) = new_XPVCV();
1117 Zero(SvANY(sv), 1, XPVCV);
1123 SvMAGIC(sv) = magic;
1124 SvSTASH(sv) = stash;
1127 SvANY(sv) = new_XPVGV();
1133 SvMAGIC(sv) = magic;
1134 SvSTASH(sv) = stash;
1142 SvANY(sv) = new_XPVBM();
1148 SvMAGIC(sv) = magic;
1149 SvSTASH(sv) = stash;
1155 SvANY(sv) = new_XPVFM();
1156 Zero(SvANY(sv), 1, XPVFM);
1162 SvMAGIC(sv) = magic;
1163 SvSTASH(sv) = stash;
1166 SvANY(sv) = new_XPVIO();
1167 Zero(SvANY(sv), 1, XPVIO);
1173 SvMAGIC(sv) = magic;
1174 SvSTASH(sv) = stash;
1175 IoPAGE_LEN(sv) = 60;
1178 SvFLAGS(sv) &= ~SVTYPEMASK;
1184 Perl_sv_backoff(pTHX_ register SV *sv)
1188 char *s = SvPVX(sv);
1189 SvLEN(sv) += SvIVX(sv);
1190 SvPVX(sv) -= SvIVX(sv);
1192 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1194 SvFLAGS(sv) &= ~SVf_OOK;
1201 Expands the character buffer in the SV. This will use C<sv_unref> and will
1202 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1209 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1213 #ifdef HAS_64K_LIMIT
1214 if (newlen >= 0x10000) {
1215 PerlIO_printf(Perl_debug_log,
1216 "Allocation too large: %"UVxf"\n", (UV)newlen);
1219 #endif /* HAS_64K_LIMIT */
1222 if (SvTYPE(sv) < SVt_PV) {
1223 sv_upgrade(sv, SVt_PV);
1226 else if (SvOOK(sv)) { /* pv is offset? */
1229 if (newlen > SvLEN(sv))
1230 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1231 #ifdef HAS_64K_LIMIT
1232 if (newlen >= 0x10000)
1238 if (newlen > SvLEN(sv)) { /* need more room? */
1239 if (SvLEN(sv) && s) {
1240 #if defined(MYMALLOC) && !defined(LEAKTEST)
1241 STRLEN l = malloced_size((void*)SvPVX(sv));
1247 Renew(s,newlen,char);
1250 New(703,s,newlen,char);
1252 SvLEN_set(sv, newlen);
1258 =for apidoc sv_setiv
1260 Copies an integer into the given SV. Does not handle 'set' magic. See
1267 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1269 SV_CHECK_THINKFIRST(sv);
1270 switch (SvTYPE(sv)) {
1272 sv_upgrade(sv, SVt_IV);
1275 sv_upgrade(sv, SVt_PVNV);
1279 sv_upgrade(sv, SVt_PVIV);
1288 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1289 PL_op_desc[PL_op->op_type]);
1291 (void)SvIOK_only(sv); /* validate number */
1297 =for apidoc sv_setiv_mg
1299 Like C<sv_setiv>, but also handles 'set' magic.
1305 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1312 =for apidoc sv_setuv
1314 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1321 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1323 /* With these two if statements:
1324 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1327 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1329 If you wish to remove them, please benchmark to see what the effect is
1331 if (u <= (UV)IV_MAX) {
1332 sv_setiv(sv, (IV)u);
1341 =for apidoc sv_setuv_mg
1343 Like C<sv_setuv>, but also handles 'set' magic.
1349 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1351 /* With these two if statements:
1352 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1355 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1357 If you wish to remove them, please benchmark to see what the effect is
1359 if (u <= (UV)IV_MAX) {
1360 sv_setiv(sv, (IV)u);
1370 =for apidoc sv_setnv
1372 Copies a double into the given SV. Does not handle 'set' magic. See
1379 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1381 SV_CHECK_THINKFIRST(sv);
1382 switch (SvTYPE(sv)) {
1385 sv_upgrade(sv, SVt_NV);
1390 sv_upgrade(sv, SVt_PVNV);
1399 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1400 PL_op_name[PL_op->op_type]);
1403 (void)SvNOK_only(sv); /* validate number */
1408 =for apidoc sv_setnv_mg
1410 Like C<sv_setnv>, but also handles 'set' magic.
1416 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1423 S_not_a_number(pTHX_ SV *sv)
1428 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1429 /* each *s can expand to 4 chars + "...\0",
1430 i.e. need room for 8 chars */
1432 for (s = SvPVX(sv); *s && d < limit; s++) {
1434 if (ch & 128 && !isPRINT_LC(ch)) {
1443 else if (ch == '\r') {
1447 else if (ch == '\f') {
1451 else if (ch == '\\') {
1455 else if (isPRINT_LC(ch))
1470 Perl_warner(aTHX_ WARN_NUMERIC,
1471 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1472 PL_op_desc[PL_op->op_type]);
1474 Perl_warner(aTHX_ WARN_NUMERIC,
1475 "Argument \"%s\" isn't numeric", tmpbuf);
1478 /* the number can be converted to integer with atol() or atoll() although */
1479 #define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
1480 #define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
1481 #define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
1482 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1483 #define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
1484 #define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
1485 #define IS_NUMBER_NEG 0x40 /* seen a leading - */
1486 #define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
1488 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1489 until proven guilty, assume that things are not that bad... */
1491 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1492 an IV (an assumption perl has been based on to date) it becomes necessary
1493 to remove the assumption that the NV always carries enough precision to
1494 recreate the IV whenever needed, and that the NV is the canonical form.
1495 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1496 precision as an side effect of conversion (which would lead to insanity
1497 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1498 1) to distinguish between IV/UV/NV slots that have cached a valid
1499 conversion where precision was lost and IV/UV/NV slots that have a
1500 valid conversion which has lost no precision
1501 2) to ensure that if a numeric conversion to one form is request that
1502 would lose precision, the precise conversion (or differently
1503 imprecise conversion) is also performed and cached, to prevent
1504 requests for different numeric formats on the same SV causing
1505 lossy conversion chains. (lossless conversion chains are perfectly
1510 SvIOKp is true if the IV slot contains a valid value
1511 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1512 SvNOKp is true if the NV slot contains a valid value
1513 SvNOK is true only if the NV value is accurate
1516 while converting from PV to NV check to see if converting that NV to an
1517 IV(or UV) would lose accuracy over a direct conversion from PV to
1518 IV(or UV). If it would, cache both conversions, return NV, but mark
1519 SV as IOK NOKp (ie not NOK).
1521 while converting from PV to IV check to see if converting that IV to an
1522 NV would lose accuracy over a direct conversion from PV to NV. If it
1523 would, cache both conversions, flag similarly.
1525 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1526 correctly because if IV & NV were set NV *always* overruled.
1527 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1528 changes - now IV and NV together means that the two are interchangeable
1529 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1531 The benefit of this is operations such as pp_add know that if SvIOK is
1532 true for both left and right operands, then integer addition can be
1533 used instead of floating point. (for cases where the result won't
1534 overflow) Before, floating point was always used, which could lead to
1535 loss of precision compared with integer addition.
1537 * making IV and NV equal status should make maths accurate on 64 bit
1539 * may speed up maths somewhat if pp_add and friends start to use
1540 integers when possible instead of fp. (hopefully the overhead in
1541 looking for SvIOK and checking for overflow will not outweigh the
1542 fp to integer speedup)
1543 * will slow down integer operations (callers of SvIV) on "inaccurate"
1544 values, as the change from SvIOK to SvIOKp will cause a call into
1545 sv_2iv each time rather than a macro access direct to the IV slot
1546 * should speed up number->string conversion on integers as IV is
1547 favoured when IV and NV equally accurate
1549 ####################################################################
1550 You had better be using SvIOK_notUV if you want an IV for arithmetic
1551 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1552 SvUOK is true iff UV.
1553 ####################################################################
1555 Your mileage will vary depending your CPUs relative fp to integer
1559 #ifndef NV_PRESERVES_UV
1560 #define IS_NUMBER_UNDERFLOW_IV 1
1561 #define IS_NUMBER_UNDERFLOW_UV 2
1562 #define IS_NUMBER_IV_AND_UV 2
1563 #define IS_NUMBER_OVERFLOW_IV 4
1564 #define IS_NUMBER_OVERFLOW_UV 5
1565 /* Hopefully your optimiser will consider inlining these two functions. */
1567 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1568 NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
1569 UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
1570 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype));
1571 if (nv_as_uv <= (UV)IV_MAX) {
1572 (void)SvIOKp_on(sv);
1573 (void)SvNOKp_on(sv);
1574 /* Within suitable range to fit in an IV, atol won't overflow */
1575 /* XXX quite sure? Is that your final answer? not really, I'm
1576 trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1577 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1578 if (numtype & IS_NUMBER_NOT_INT) {
1579 /* I believe that even if the original PV had decimals, they
1580 are lost beyond the limit of the FP precision.
1581 However, neither is canonical, so both only get p flags.
1583 /* Both already have p flags, so do nothing */
1584 } else if (SvIVX(sv) == I_V(nv)) {
1589 /* It had no "." so it must be integer. assert (get in here from
1590 sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1591 IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1592 conversion routines need audit. */
1594 return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1596 /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1597 (void)SvIOKp_on(sv);
1598 (void)SvNOKp_on(sv);
1601 int save_errno = errno;
1603 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1605 if (numtype & IS_NUMBER_NOT_INT) {
1606 /* UV and NV both imprecise. */
1608 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1617 return IS_NUMBER_OVERFLOW_IV;
1621 /* Must have just overflowed UV, but not enough that an NV could spot
1623 return IS_NUMBER_OVERFLOW_UV;
1626 /* We've just lost integer precision, nothing we could do. */
1627 SvUVX(sv) = nv_as_uv;
1628 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype));
1629 /* UV and NV slots equally valid only if we have casting symmetry. */
1630 if (numtype & IS_NUMBER_NOT_INT) {
1632 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1633 /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1634 UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1635 get to this point if NVs don't preserve UVs) */
1640 /* As above, I believe UV at least as good as NV */
1643 #endif /* HAS_STRTOUL */
1644 return IS_NUMBER_OVERFLOW_IV;
1647 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1649 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1651 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype));
1652 if (SvNVX(sv) < (NV)IV_MIN) {
1653 (void)SvIOKp_on(sv);
1656 return IS_NUMBER_UNDERFLOW_IV;
1658 if (SvNVX(sv) > (NV)UV_MAX) {
1659 (void)SvIOKp_on(sv);
1663 return IS_NUMBER_OVERFLOW_UV;
1665 if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1666 (void)SvIOKp_on(sv);
1668 /* Can't use strtol etc to convert this string */
1669 if (SvNVX(sv) <= (UV)IV_MAX) {
1670 SvIVX(sv) = I_V(SvNVX(sv));
1671 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1672 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1674 /* Integer is imprecise. NOK, IOKp */
1676 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1679 SvUVX(sv) = U_V(SvNVX(sv));
1680 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1681 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1683 /* Integer is imprecise. NOK, IOKp */
1685 return IS_NUMBER_OVERFLOW_IV;
1687 return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
1689 #endif /* NV_PRESERVES_UV*/
1692 Perl_sv_2iv(pTHX_ register SV *sv)
1696 if (SvGMAGICAL(sv)) {
1701 return I_V(SvNVX(sv));
1703 if (SvPOKp(sv) && SvLEN(sv))
1706 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1707 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1713 if (SvTHINKFIRST(sv)) {
1716 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1717 (SvRV(tmpstr) != SvRV(sv)))
1718 return SvIV(tmpstr);
1719 return PTR2IV(SvRV(sv));
1721 if (SvREADONLY(sv) && SvFAKE(sv)) {
1722 sv_force_normal(sv);
1724 if (SvREADONLY(sv) && !SvOK(sv)) {
1725 if (ckWARN(WARN_UNINITIALIZED))
1732 return (IV)(SvUVX(sv));
1739 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1740 * without also getting a cached IV/UV from it at the same time
1741 * (ie PV->NV conversion should detect loss of accuracy and cache
1742 * IV or UV at same time to avoid this. NWC */
1744 if (SvTYPE(sv) == SVt_NV)
1745 sv_upgrade(sv, SVt_PVNV);
1747 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1748 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1749 certainly cast into the IV range at IV_MAX, whereas the correct
1750 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1752 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1753 SvIVX(sv) = I_V(SvNVX(sv));
1754 if (SvNVX(sv) == (NV) SvIVX(sv)
1755 #ifndef NV_PRESERVES_UV
1756 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1757 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1758 /* Don't flag it as "accurately an integer" if the number
1759 came from a (by definition imprecise) NV operation, and
1760 we're outside the range of NV integer precision */
1763 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1764 DEBUG_c(PerlIO_printf(Perl_debug_log,
1765 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1771 /* IV not precise. No need to convert from PV, as NV
1772 conversion would already have cached IV if it detected
1773 that PV->IV would be better than PV->NV->IV
1774 flags already correct - don't set public IOK. */
1775 DEBUG_c(PerlIO_printf(Perl_debug_log,
1776 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1781 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1782 but the cast (NV)IV_MIN rounds to a the value less (more
1783 negative) than IV_MIN which happens to be equal to SvNVX ??
1784 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1785 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1786 (NV)UVX == NVX are both true, but the values differ. :-(
1787 Hopefully for 2s complement IV_MIN is something like
1788 0x8000000000000000 which will be exact. NWC */
1791 SvUVX(sv) = U_V(SvNVX(sv));
1793 (SvNVX(sv) == (NV) SvUVX(sv))
1794 #ifndef NV_PRESERVES_UV
1795 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1796 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1797 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1798 /* Don't flag it as "accurately an integer" if the number
1799 came from a (by definition imprecise) NV operation, and
1800 we're outside the range of NV integer precision */
1806 DEBUG_c(PerlIO_printf(Perl_debug_log,
1807 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1811 return (IV)SvUVX(sv);
1814 else if (SvPOKp(sv) && SvLEN(sv)) {
1815 I32 numtype = looks_like_number(sv);
1817 /* We want to avoid a possible problem when we cache an IV which
1818 may be later translated to an NV, and the resulting NV is not
1819 the translation of the initial data.
1821 This means that if we cache such an IV, we need to cache the
1822 NV as well. Moreover, we trade speed for space, and do not
1823 cache the NV if we are sure it's not needed.
1826 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1827 /* The NV may be reconstructed from IV - safe to cache IV,
1828 which may be calculated by atol(). */
1829 if (SvTYPE(sv) < SVt_PVIV)
1830 sv_upgrade(sv, SVt_PVIV);
1832 SvIVX(sv) = Atol(SvPVX(sv));
1836 int save_errno = errno;
1837 /* Is it an integer that we could convert with strtol?
1838 So try it, and if it doesn't set errno then it's pukka.
1839 This should be faster than going atof and then thinking. */
1840 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1841 == IS_NUMBER_TO_INT_BY_STRTOL)
1842 /* && is a sequence point. Without it not sure if I'm trying
1843 to do too much between sequence points and hence going
1845 && ((errno = 0), 1) /* , 1 so always true */
1846 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1848 if (SvTYPE(sv) < SVt_PVIV)
1849 sv_upgrade(sv, SVt_PVIV);
1858 /* Hopefully trace flow will optimise this away where possible
1862 /* It wasn't an integer, or it overflowed, or we don't have
1863 strtol. Do things the slow way - check if it's a UV etc. */
1864 d = Atof(SvPVX(sv));
1866 if (SvTYPE(sv) < SVt_PVNV)
1867 sv_upgrade(sv, SVt_PVNV);
1870 if (! numtype && ckWARN(WARN_NUMERIC))
1873 #if defined(USE_LONG_DOUBLE)
1874 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1875 PTR2UV(sv), SvNVX(sv)));
1877 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1878 PTR2UV(sv), SvNVX(sv)));
1882 #ifdef NV_PRESERVES_UV
1883 (void)SvIOKp_on(sv);
1885 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1886 SvIVX(sv) = I_V(SvNVX(sv));
1887 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1890 /* Integer is imprecise. NOK, IOKp */
1892 /* UV will not work better than IV */
1894 if (SvNVX(sv) > (NV)UV_MAX) {
1896 /* Integer is inaccurate. NOK, IOKp, is UV */
1900 SvUVX(sv) = U_V(SvNVX(sv));
1901 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1902 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1906 /* Integer is imprecise. NOK, IOKp, is UV */
1912 #else /* NV_PRESERVES_UV */
1913 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1914 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1915 /* Small enough to preserve all bits. */
1916 (void)SvIOKp_on(sv);
1918 SvIVX(sv) = I_V(SvNVX(sv));
1919 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1921 /* Assumption: first non-preserved integer is < IV_MAX,
1922 this NV is in the preserved range, therefore: */
1923 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1925 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
1927 } else if (sv_2iuv_non_preserve (sv, numtype)
1928 >= IS_NUMBER_OVERFLOW_IV)
1930 #endif /* NV_PRESERVES_UV */
1934 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1936 if (SvTYPE(sv) < SVt_IV)
1937 /* Typically the caller expects that sv_any is not NULL now. */
1938 sv_upgrade(sv, SVt_IV);
1941 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1942 PTR2UV(sv),SvIVX(sv)));
1943 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1947 Perl_sv_2uv(pTHX_ register SV *sv)
1951 if (SvGMAGICAL(sv)) {
1956 return U_V(SvNVX(sv));
1957 if (SvPOKp(sv) && SvLEN(sv))
1960 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1961 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1967 if (SvTHINKFIRST(sv)) {
1970 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1971 (SvRV(tmpstr) != SvRV(sv)))
1972 return SvUV(tmpstr);
1973 return PTR2UV(SvRV(sv));
1975 if (SvREADONLY(sv) && SvFAKE(sv)) {
1976 sv_force_normal(sv);
1978 if (SvREADONLY(sv) && !SvOK(sv)) {
1979 if (ckWARN(WARN_UNINITIALIZED))
1989 return (UV)SvIVX(sv);
1993 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1994 * without also getting a cached IV/UV from it at the same time
1995 * (ie PV->NV conversion should detect loss of accuracy and cache
1996 * IV or UV at same time to avoid this. */
1997 /* IV-over-UV optimisation - choose to cache IV if possible */
1999 if (SvTYPE(sv) == SVt_NV)
2000 sv_upgrade(sv, SVt_PVNV);
2002 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2003 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2004 SvIVX(sv) = I_V(SvNVX(sv));
2005 if (SvNVX(sv) == (NV) SvIVX(sv)
2006 #ifndef NV_PRESERVES_UV
2007 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2008 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2009 /* Don't flag it as "accurately an integer" if the number
2010 came from a (by definition imprecise) NV operation, and
2011 we're outside the range of NV integer precision */
2014 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2015 DEBUG_c(PerlIO_printf(Perl_debug_log,
2016 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2022 /* IV not precise. No need to convert from PV, as NV
2023 conversion would already have cached IV if it detected
2024 that PV->IV would be better than PV->NV->IV
2025 flags already correct - don't set public IOK. */
2026 DEBUG_c(PerlIO_printf(Perl_debug_log,
2027 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2032 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2033 but the cast (NV)IV_MIN rounds to a the value less (more
2034 negative) than IV_MIN which happens to be equal to SvNVX ??
2035 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2036 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2037 (NV)UVX == NVX are both true, but the values differ. :-(
2038 Hopefully for 2s complement IV_MIN is something like
2039 0x8000000000000000 which will be exact. NWC */
2042 SvUVX(sv) = U_V(SvNVX(sv));
2044 (SvNVX(sv) == (NV) SvUVX(sv))
2045 #ifndef NV_PRESERVES_UV
2046 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2047 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2048 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2049 /* Don't flag it as "accurately an integer" if the number
2050 came from a (by definition imprecise) NV operation, and
2051 we're outside the range of NV integer precision */
2056 DEBUG_c(PerlIO_printf(Perl_debug_log,
2057 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2063 else if (SvPOKp(sv) && SvLEN(sv)) {
2064 I32 numtype = looks_like_number(sv);
2066 /* We want to avoid a possible problem when we cache a UV which
2067 may be later translated to an NV, and the resulting NV is not
2068 the translation of the initial data.
2070 This means that if we cache such a UV, we need to cache the
2071 NV as well. Moreover, we trade speed for space, and do not
2072 cache the NV if not needed.
2075 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2076 /* The NV may be reconstructed from IV - safe to cache IV,
2077 which may be calculated by atol(). */
2078 if (SvTYPE(sv) < SVt_PVIV)
2079 sv_upgrade(sv, SVt_PVIV);
2081 SvIVX(sv) = Atol(SvPVX(sv));
2085 char *num_begin = SvPVX(sv);
2086 int save_errno = errno;
2088 /* seems that strtoul taking numbers that start with - is
2089 implementation dependant, and can't be relied upon. */
2090 if (numtype & IS_NUMBER_NEG) {
2091 /* Not totally defensive. assumine that looks_like_num
2092 didn't lie about a - sign */
2093 while (isSPACE(*num_begin))
2095 if (*num_begin == '-')
2099 /* Is it an integer that we could convert with strtoul?
2100 So try it, and if it doesn't set errno then it's pukka.
2101 This should be faster than going atof and then thinking. */
2102 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2103 == IS_NUMBER_TO_INT_BY_STRTOL)
2104 && ((errno = 0), 1) /* always true */
2105 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2107 /* If known to be negative, check it didn't undeflow IV
2108 XXX possibly we should put more negative values as NVs
2109 direct rather than go via atof below */
2110 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2113 if (SvTYPE(sv) < SVt_PVIV)
2114 sv_upgrade(sv, SVt_PVIV);
2117 /* If it's negative must use IV.
2118 IV-over-UV optimisation */
2119 if (numtype & IS_NUMBER_NEG) {
2121 } else if (u <= (UV) IV_MAX) {
2124 /* it didn't overflow, and it was positive. */
2133 /* Hopefully trace flow will optimise this away where possible
2137 /* It wasn't an integer, or it overflowed, or we don't have
2138 strtol. Do things the slow way - check if it's a IV etc. */
2139 d = Atof(SvPVX(sv));
2141 if (SvTYPE(sv) < SVt_PVNV)
2142 sv_upgrade(sv, SVt_PVNV);
2145 if (! numtype && ckWARN(WARN_NUMERIC))
2148 #if defined(USE_LONG_DOUBLE)
2149 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2150 PTR2UV(sv), SvNVX(sv)));
2152 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2153 PTR2UV(sv), SvNVX(sv)));
2156 #ifdef NV_PRESERVES_UV
2157 (void)SvIOKp_on(sv);
2159 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2160 SvIVX(sv) = I_V(SvNVX(sv));
2161 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2164 /* Integer is imprecise. NOK, IOKp */
2166 /* UV will not work better than IV */
2168 if (SvNVX(sv) > (NV)UV_MAX) {
2170 /* Integer is inaccurate. NOK, IOKp, is UV */
2174 SvUVX(sv) = U_V(SvNVX(sv));
2175 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2176 NV preservse UV so can do correct comparison. */
2177 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2181 /* Integer is imprecise. NOK, IOKp, is UV */
2186 #else /* NV_PRESERVES_UV */
2187 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2188 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2189 /* Small enough to preserve all bits. */
2190 (void)SvIOKp_on(sv);
2192 SvIVX(sv) = I_V(SvNVX(sv));
2193 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2195 /* Assumption: first non-preserved integer is < IV_MAX,
2196 this NV is in the preserved range, therefore: */
2197 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2199 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2202 sv_2iuv_non_preserve (sv, numtype);
2203 #endif /* NV_PRESERVES_UV */
2208 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2209 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2212 if (SvTYPE(sv) < SVt_IV)
2213 /* Typically the caller expects that sv_any is not NULL now. */
2214 sv_upgrade(sv, SVt_IV);
2218 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2219 PTR2UV(sv),SvUVX(sv)));
2220 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2224 Perl_sv_2nv(pTHX_ register SV *sv)
2228 if (SvGMAGICAL(sv)) {
2232 if (SvPOKp(sv) && SvLEN(sv)) {
2233 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2235 return Atof(SvPVX(sv));
2239 return (NV)SvUVX(sv);
2241 return (NV)SvIVX(sv);
2244 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2245 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2251 if (SvTHINKFIRST(sv)) {
2254 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2255 (SvRV(tmpstr) != SvRV(sv)))
2256 return SvNV(tmpstr);
2257 return PTR2NV(SvRV(sv));
2259 if (SvREADONLY(sv) && SvFAKE(sv)) {
2260 sv_force_normal(sv);
2262 if (SvREADONLY(sv) && !SvOK(sv)) {
2263 if (ckWARN(WARN_UNINITIALIZED))
2268 if (SvTYPE(sv) < SVt_NV) {
2269 if (SvTYPE(sv) == SVt_IV)
2270 sv_upgrade(sv, SVt_PVNV);
2272 sv_upgrade(sv, SVt_NV);
2273 #if defined(USE_LONG_DOUBLE)
2275 STORE_NUMERIC_LOCAL_SET_STANDARD();
2276 PerlIO_printf(Perl_debug_log,
2277 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2278 PTR2UV(sv), SvNVX(sv));
2279 RESTORE_NUMERIC_LOCAL();
2283 STORE_NUMERIC_LOCAL_SET_STANDARD();
2284 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2285 PTR2UV(sv), SvNVX(sv));
2286 RESTORE_NUMERIC_LOCAL();
2290 else if (SvTYPE(sv) < SVt_PVNV)
2291 sv_upgrade(sv, SVt_PVNV);
2293 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2295 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2296 #ifdef NV_PRESERVES_UV
2299 /* Only set the public NV OK flag if this NV preserves the IV */
2300 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2301 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2302 : (SvIVX(sv) == I_V(SvNVX(sv))))
2308 else if (SvPOKp(sv) && SvLEN(sv)) {
2309 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2311 SvNVX(sv) = Atof(SvPVX(sv));
2312 #ifdef NV_PRESERVES_UV
2315 /* Only set the public NV OK flag if this NV preserves the value in
2316 the PV at least as well as an IV/UV would.
2317 Not sure how to do this 100% reliably. */
2318 /* if that shift count is out of range then Configure's test is
2319 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2321 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2322 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2323 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2324 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2325 /* Definitely too large/small to fit in an integer, so no loss
2326 of precision going to integer in the future via NV */
2329 /* Is it something we can run through strtol etc (ie no
2330 trailing exponent part)? */
2331 int numtype = looks_like_number(sv);
2332 /* XXX probably should cache this if called above */
2335 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2336 /* Can't use strtol etc to convert this string, so don't try */
2339 sv_2inuv_non_preserve (sv, numtype);
2341 #endif /* NV_PRESERVES_UV */
2344 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2346 if (SvTYPE(sv) < SVt_NV)
2347 /* Typically the caller expects that sv_any is not NULL now. */
2348 /* XXX Ilya implies that this is a bug in callers that assume this
2349 and ideally should be fixed. */
2350 sv_upgrade(sv, SVt_NV);
2353 #if defined(USE_LONG_DOUBLE)
2355 STORE_NUMERIC_LOCAL_SET_STANDARD();
2356 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2357 PTR2UV(sv), SvNVX(sv));
2358 RESTORE_NUMERIC_LOCAL();
2362 STORE_NUMERIC_LOCAL_SET_STANDARD();
2363 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2364 PTR2UV(sv), SvNVX(sv));
2365 RESTORE_NUMERIC_LOCAL();
2372 S_asIV(pTHX_ SV *sv)
2374 I32 numtype = looks_like_number(sv);
2377 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2378 return Atol(SvPVX(sv));
2380 if (ckWARN(WARN_NUMERIC))
2383 d = Atof(SvPVX(sv));
2388 S_asUV(pTHX_ SV *sv)
2390 I32 numtype = looks_like_number(sv);
2393 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2394 return Strtoul(SvPVX(sv), Null(char**), 10);
2397 if (ckWARN(WARN_NUMERIC))
2400 return U_V(Atof(SvPVX(sv)));
2404 * Returns a combination of (advisory only - can get false negatives)
2405 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2406 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2407 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2408 * 0 if does not look like number.
2410 * (atol and strtol stop when they hit a decimal point. strtol will return
2411 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2412 * do this, and vendors have had 11 years to get it right.
2413 * However, will try to make it still work with only atol
2415 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2416 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2417 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2418 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2419 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2420 * IS_NUMBER_NOT_INT saw "." or "e"
2422 * IS_NUMBER_INFINITY
2426 =for apidoc looks_like_number
2428 Test if an the content of an SV looks like a number (or is a
2429 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2430 issue a non-numeric warning), even if your atof() doesn't grok them.
2436 Perl_looks_like_number(pTHX_ SV *sv)
2439 register char *send;
2440 register char *sbegin;
2441 register char *nbegin;
2450 else if (SvPOKp(sv))
2451 sbegin = SvPV(sv, len);
2454 send = sbegin + len;
2461 numtype = IS_NUMBER_NEG;
2468 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2469 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2470 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2471 * will need (int)atof().
2474 /* next must be digit or the radix separator or beginning of infinity */
2478 } while (isDIGIT(*s));
2480 /* Aaargh. long long really is irritating.
2481 In the gospel according to ANSI 1989, it is an axiom that "long"
2482 is the longest integer type, and that if you don't know how long
2483 something is you can cast it to long, and nothing will be lost
2484 (except possibly speed of execution if long is slower than the
2486 Now, one can't be sure if the old rules apply, or long long
2487 (or some other newfangled thing) is actually longer than the
2488 (formerly) longest thing.
2490 /* This lot will work for 64 bit *as long as* either
2491 either long is 64 bit
2492 or we can find both strtol/strtoq and strtoul/strtouq
2493 If not, we really should refuse to let the user use 64 bit IVs
2494 By "64 bit" I really mean IVs that don't get preserved by NVs
2495 It also should work for 128 bit IVs. Can any lend me a machine to
2498 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2499 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2500 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2501 ? sizeof(long) : sizeof (IV))*8-1))
2502 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2504 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2505 digit less (IV_MAX= 9223372036854775807,
2506 UV_MAX= 18446744073709551615) so be cautious */
2507 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2510 #ifdef USE_LOCALE_NUMERIC
2511 || IS_NUMERIC_RADIX(*s)
2515 numtype |= IS_NUMBER_NOT_INT;
2516 while (isDIGIT(*s)) /* optional digits after the radix */
2521 #ifdef USE_LOCALE_NUMERIC
2522 || IS_NUMERIC_RADIX(*s)
2526 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2527 /* no digits before the radix means we need digits after it */
2531 } while (isDIGIT(*s));
2536 else if (*s == 'I' || *s == 'i') {
2537 s++; if (*s != 'N' && *s != 'n') return 0;
2538 s++; if (*s != 'F' && *s != 'f') return 0;
2539 s++; if (*s == 'I' || *s == 'i') {
2540 s++; if (*s != 'N' && *s != 'n') return 0;
2541 s++; if (*s != 'I' && *s != 'i') return 0;
2542 s++; if (*s != 'T' && *s != 't') return 0;
2543 s++; if (*s != 'Y' && *s != 'y') return 0;
2552 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2553 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2555 /* we can have an optional exponent part */
2556 if (*s == 'e' || *s == 'E') {
2557 numtype &= IS_NUMBER_NEG;
2558 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2560 if (*s == '+' || *s == '-')
2565 } while (isDIGIT(*s));
2575 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2576 return IS_NUMBER_TO_INT_BY_ATOL;
2581 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2584 return sv_2pv(sv, &n_a);
2587 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2589 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2591 char *ptr = buf + TYPE_CHARS(UV);
2605 *--ptr = '0' + (uv % 10);
2614 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2619 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2620 char *tmpbuf = tbuf;
2626 if (SvGMAGICAL(sv)) {
2634 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2636 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2641 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2646 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2647 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2654 if (SvTHINKFIRST(sv)) {
2657 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2658 (SvRV(tmpstr) != SvRV(sv)))
2659 return SvPV(tmpstr,*lp);
2666 switch (SvTYPE(sv)) {
2668 if ( ((SvFLAGS(sv) &
2669 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2670 == (SVs_OBJECT|SVs_RMG))
2671 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2672 && (mg = mg_find(sv, 'r'))) {
2673 regexp *re = (regexp *)mg->mg_obj;
2676 char *fptr = "msix";
2681 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2683 while((ch = *fptr++)) {
2685 reflags[left++] = ch;
2688 reflags[right--] = ch;
2693 reflags[left] = '-';
2697 mg->mg_len = re->prelen + 4 + left;
2698 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2699 Copy("(?", mg->mg_ptr, 2, char);
2700 Copy(reflags, mg->mg_ptr+2, left, char);
2701 Copy(":", mg->mg_ptr+left+2, 1, char);
2702 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2703 mg->mg_ptr[mg->mg_len - 1] = ')';
2704 mg->mg_ptr[mg->mg_len] = 0;
2706 PL_reginterp_cnt += re->program[0].next_off;
2718 case SVt_PVBM: if (SvROK(sv))
2721 s = "SCALAR"; break;
2722 case SVt_PVLV: s = "LVALUE"; break;
2723 case SVt_PVAV: s = "ARRAY"; break;
2724 case SVt_PVHV: s = "HASH"; break;
2725 case SVt_PVCV: s = "CODE"; break;
2726 case SVt_PVGV: s = "GLOB"; break;
2727 case SVt_PVFM: s = "FORMAT"; break;
2728 case SVt_PVIO: s = "IO"; break;
2729 default: s = "UNKNOWN"; break;
2733 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2736 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2742 if (SvREADONLY(sv) && !SvOK(sv)) {
2743 if (ckWARN(WARN_UNINITIALIZED))
2749 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2750 /* I'm assuming that if both IV and NV are equally valid then
2751 converting the IV is going to be more efficient */
2752 U32 isIOK = SvIOK(sv);
2753 U32 isUIOK = SvIsUV(sv);
2754 char buf[TYPE_CHARS(UV)];
2757 if (SvTYPE(sv) < SVt_PVIV)
2758 sv_upgrade(sv, SVt_PVIV);
2760 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2762 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2763 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2764 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2765 SvCUR_set(sv, ebuf - ptr);
2775 else if (SvNOKp(sv)) {
2776 if (SvTYPE(sv) < SVt_PVNV)
2777 sv_upgrade(sv, SVt_PVNV);
2778 /* The +20 is pure guesswork. Configure test needed. --jhi */
2779 SvGROW(sv, NV_DIG + 20);
2781 olderrno = errno; /* some Xenix systems wipe out errno here */
2783 if (SvNVX(sv) == 0.0)
2784 (void)strcpy(s,"0");
2788 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2791 #ifdef FIXNEGATIVEZERO
2792 if (*s == '-' && s[1] == '0' && !s[2])
2802 if (ckWARN(WARN_UNINITIALIZED)
2803 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2806 if (SvTYPE(sv) < SVt_PV)
2807 /* Typically the caller expects that sv_any is not NULL now. */
2808 sv_upgrade(sv, SVt_PV);
2811 *lp = s - SvPVX(sv);
2814 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2815 PTR2UV(sv),SvPVX(sv)));
2819 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2820 /* Sneaky stuff here */
2824 tsv = newSVpv(tmpbuf, 0);
2840 len = strlen(tmpbuf);
2842 #ifdef FIXNEGATIVEZERO
2843 if (len == 2 && t[0] == '-' && t[1] == '0') {
2848 (void)SvUPGRADE(sv, SVt_PV);
2850 s = SvGROW(sv, len + 1);
2859 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2862 return sv_2pvbyte(sv, &n_a);
2866 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2868 return sv_2pv(sv,lp);
2872 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2875 return sv_2pvutf8(sv, &n_a);
2879 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2881 sv_utf8_upgrade(sv);
2882 return SvPV(sv,*lp);
2885 /* This function is only called on magical items */
2887 Perl_sv_2bool(pTHX_ register SV *sv)
2896 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2897 (SvRV(tmpsv) != SvRV(sv)))
2898 return SvTRUE(tmpsv);
2899 return SvRV(sv) != 0;
2902 register XPV* Xpvtmp;
2903 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2904 (*Xpvtmp->xpv_pv > '0' ||
2905 Xpvtmp->xpv_cur > 1 ||
2906 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2913 return SvIVX(sv) != 0;
2916 return SvNVX(sv) != 0.0;
2924 =for apidoc sv_utf8_upgrade
2926 Convert the PV of an SV to its UTF8-encoded form.
2932 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2937 if (!sv || !SvPOK(sv) || SvUTF8(sv))
2940 /* This function could be much more efficient if we had a FLAG in SVs
2941 * to signal if there are any hibit chars in the PV.
2942 * Given that there isn't make loop fast as possible
2948 if ((hibit = *t++ & 0x80))
2954 if (SvREADONLY(sv) && SvFAKE(sv)) {
2955 sv_force_normal(sv);
2958 len = SvCUR(sv) + 1; /* Plus the \0 */
2959 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2960 SvCUR(sv) = len - 1;
2962 Safefree(s); /* No longer using what was there before. */
2963 SvLEN(sv) = len; /* No longer know the real size. */
2969 =for apidoc sv_utf8_downgrade
2971 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2972 This may not be possible if the PV contains non-byte encoding characters;
2973 if this is the case, either returns false or, if C<fail_ok> is not
2980 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2982 if (SvPOK(sv) && SvUTF8(sv)) {
2984 char *c = SvPVX(sv);
2985 STRLEN len = SvCUR(sv);
2987 if (!utf8_to_bytes((U8*)c, &len)) {
2992 Perl_croak(aTHX_ "Wide character in %s",
2993 PL_op_desc[PL_op->op_type]);
2995 Perl_croak(aTHX_ "Wide character");
3007 =for apidoc sv_utf8_encode
3009 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3010 flag so that it looks like bytes again. Nothing calls this.
3016 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3018 sv_utf8_upgrade(sv);
3023 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3028 bool has_utf = FALSE;
3029 if (!sv_utf8_downgrade(sv, TRUE))
3032 /* it is actually just a matter of turning the utf8 flag on, but
3033 * we want to make sure everything inside is valid utf8 first.
3036 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
3050 /* Note: sv_setsv() should not be called with a source string that needs
3051 * to be reused, since it may destroy the source string if it is marked
3056 =for apidoc sv_setsv
3058 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3059 The source SV may be destroyed if it is mortal. Does not handle 'set'
3060 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3067 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3069 register U32 sflags;
3075 SV_CHECK_THINKFIRST(dstr);
3077 sstr = &PL_sv_undef;
3078 stype = SvTYPE(sstr);
3079 dtype = SvTYPE(dstr);
3083 /* There's a lot of redundancy below but we're going for speed here */
3088 if (dtype != SVt_PVGV) {
3089 (void)SvOK_off(dstr);
3097 sv_upgrade(dstr, SVt_IV);
3100 sv_upgrade(dstr, SVt_PVNV);
3104 sv_upgrade(dstr, SVt_PVIV);
3107 (void)SvIOK_only(dstr);
3108 SvIVX(dstr) = SvIVX(sstr);
3111 if (SvTAINTED(sstr))
3122 sv_upgrade(dstr, SVt_NV);
3127 sv_upgrade(dstr, SVt_PVNV);
3130 SvNVX(dstr) = SvNVX(sstr);
3131 (void)SvNOK_only(dstr);
3132 if (SvTAINTED(sstr))
3140 sv_upgrade(dstr, SVt_RV);
3141 else if (dtype == SVt_PVGV &&
3142 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3145 if (GvIMPORTED(dstr) != GVf_IMPORTED
3146 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3148 GvIMPORTED_on(dstr);
3159 sv_upgrade(dstr, SVt_PV);
3162 if (dtype < SVt_PVIV)
3163 sv_upgrade(dstr, SVt_PVIV);
3166 if (dtype < SVt_PVNV)
3167 sv_upgrade(dstr, SVt_PVNV);
3174 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3175 PL_op_name[PL_op->op_type]);
3177 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3181 if (dtype <= SVt_PVGV) {
3183 if (dtype != SVt_PVGV) {
3184 char *name = GvNAME(sstr);
3185 STRLEN len = GvNAMELEN(sstr);
3186 sv_upgrade(dstr, SVt_PVGV);
3187 sv_magic(dstr, dstr, '*', Nullch, 0);
3188 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3189 GvNAME(dstr) = savepvn(name, len);
3190 GvNAMELEN(dstr) = len;
3191 SvFAKE_on(dstr); /* can coerce to non-glob */
3193 /* ahem, death to those who redefine active sort subs */
3194 else if (PL_curstackinfo->si_type == PERLSI_SORT
3195 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3196 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3198 (void)SvOK_off(dstr);
3199 GvINTRO_off(dstr); /* one-shot flag */
3201 GvGP(dstr) = gp_ref(GvGP(sstr));
3202 if (SvTAINTED(sstr))
3204 if (GvIMPORTED(dstr) != GVf_IMPORTED
3205 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3207 GvIMPORTED_on(dstr);
3215 if (SvGMAGICAL(sstr)) {
3217 if (SvTYPE(sstr) != stype) {
3218 stype = SvTYPE(sstr);
3219 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3223 if (stype == SVt_PVLV)
3224 (void)SvUPGRADE(dstr, SVt_PVNV);
3226 (void)SvUPGRADE(dstr, stype);
3229 sflags = SvFLAGS(sstr);
3231 if (sflags & SVf_ROK) {
3232 if (dtype >= SVt_PV) {
3233 if (dtype == SVt_PVGV) {
3234 SV *sref = SvREFCNT_inc(SvRV(sstr));
3236 int intro = GvINTRO(dstr);
3241 GvINTRO_off(dstr); /* one-shot flag */
3242 Newz(602,gp, 1, GP);
3243 GvGP(dstr) = gp_ref(gp);
3244 GvSV(dstr) = NEWSV(72,0);
3245 GvLINE(dstr) = CopLINE(PL_curcop);
3246 GvEGV(dstr) = (GV*)dstr;
3249 switch (SvTYPE(sref)) {
3252 SAVESPTR(GvAV(dstr));
3254 dref = (SV*)GvAV(dstr);
3255 GvAV(dstr) = (AV*)sref;
3256 if (!GvIMPORTED_AV(dstr)
3257 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3259 GvIMPORTED_AV_on(dstr);
3264 SAVESPTR(GvHV(dstr));
3266 dref = (SV*)GvHV(dstr);
3267 GvHV(dstr) = (HV*)sref;
3268 if (!GvIMPORTED_HV(dstr)
3269 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3271 GvIMPORTED_HV_on(dstr);
3276 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3277 SvREFCNT_dec(GvCV(dstr));
3278 GvCV(dstr) = Nullcv;
3279 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280 PL_sub_generation++;
3282 SAVESPTR(GvCV(dstr));
3285 dref = (SV*)GvCV(dstr);
3286 if (GvCV(dstr) != (CV*)sref) {
3287 CV* cv = GvCV(dstr);
3289 if (!GvCVGEN((GV*)dstr) &&
3290 (CvROOT(cv) || CvXSUB(cv)))
3293 /* ahem, death to those who redefine
3294 * active sort subs */
3295 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3296 PL_sortcop == CvSTART(cv))
3298 "Can't redefine active sort subroutine %s",
3299 GvENAME((GV*)dstr));
3300 /* Redefining a sub - warning is mandatory if
3301 it was a const and its value changed. */
3302 if (ckWARN(WARN_REDEFINE)
3304 && (!CvCONST((CV*)sref)
3305 || sv_cmp(cv_const_sv(cv),
3306 cv_const_sv((CV*)sref)))))
3308 Perl_warner(aTHX_ WARN_REDEFINE,
3310 ? "Constant subroutine %s redefined"
3311 : "Subroutine %s redefined",
3312 GvENAME((GV*)dstr));
3315 cv_ckproto(cv, (GV*)dstr,
3316 SvPOK(sref) ? SvPVX(sref) : Nullch);
3318 GvCV(dstr) = (CV*)sref;
3319 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3320 GvASSUMECV_on(dstr);
3321 PL_sub_generation++;
3323 if (!GvIMPORTED_CV(dstr)
3324 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3326 GvIMPORTED_CV_on(dstr);
3331 SAVESPTR(GvIOp(dstr));
3333 dref = (SV*)GvIOp(dstr);
3334 GvIOp(dstr) = (IO*)sref;
3338 SAVESPTR(GvFORM(dstr));
3340 dref = (SV*)GvFORM(dstr);
3341 GvFORM(dstr) = (CV*)sref;
3345 SAVESPTR(GvSV(dstr));
3347 dref = (SV*)GvSV(dstr);
3349 if (!GvIMPORTED_SV(dstr)
3350 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3352 GvIMPORTED_SV_on(dstr);
3360 if (SvTAINTED(sstr))
3365 (void)SvOOK_off(dstr); /* backoff */
3367 Safefree(SvPVX(dstr));
3368 SvLEN(dstr)=SvCUR(dstr)=0;
3371 (void)SvOK_off(dstr);
3372 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3374 if (sflags & SVp_NOK) {
3376 SvNVX(dstr) = SvNVX(sstr);
3378 if (sflags & SVp_IOK) {
3379 (void)SvIOK_on(dstr);
3380 SvIVX(dstr) = SvIVX(sstr);
3381 if (sflags & SVf_IVisUV)
3384 if (SvAMAGIC(sstr)) {
3388 else if (sflags & SVp_POK) {
3391 * Check to see if we can just swipe the string. If so, it's a
3392 * possible small lose on short strings, but a big win on long ones.
3393 * It might even be a win on short strings if SvPVX(dstr)
3394 * has to be allocated and SvPVX(sstr) has to be freed.
3397 if (SvTEMP(sstr) && /* slated for free anyway? */
3398 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3399 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3400 SvLEN(sstr) && /* and really is a string */
3401 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3403 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3405 SvFLAGS(dstr) &= ~SVf_OOK;
3406 Safefree(SvPVX(dstr) - SvIVX(dstr));
3408 else if (SvLEN(dstr))
3409 Safefree(SvPVX(dstr));
3411 (void)SvPOK_only(dstr);
3412 SvPV_set(dstr, SvPVX(sstr));
3413 SvLEN_set(dstr, SvLEN(sstr));
3414 SvCUR_set(dstr, SvCUR(sstr));
3417 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3418 SvPV_set(sstr, Nullch);
3423 else { /* have to copy actual string */
3424 STRLEN len = SvCUR(sstr);
3426 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3427 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3428 SvCUR_set(dstr, len);
3429 *SvEND(dstr) = '\0';
3430 (void)SvPOK_only(dstr);
3432 if ((sflags & SVf_UTF8) && !IN_BYTE)
3435 if (sflags & SVp_NOK) {
3437 SvNVX(dstr) = SvNVX(sstr);
3439 if (sflags & SVp_IOK) {
3440 (void)SvIOK_on(dstr);
3441 SvIVX(dstr) = SvIVX(sstr);
3442 if (sflags & SVf_IVisUV)
3446 else if (sflags & SVp_NOK) {
3447 SvNVX(dstr) = SvNVX(sstr);
3448 (void)SvNOK_only(dstr);
3449 if (sflags & SVf_IOK) {
3450 (void)SvIOK_on(dstr);
3451 SvIVX(dstr) = SvIVX(sstr);
3452 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3453 if (sflags & SVf_IVisUV)
3457 else if (sflags & SVp_IOK) {
3458 (void)SvIOK_only(dstr);
3459 SvIVX(dstr) = SvIVX(sstr);
3460 if (sflags & SVf_IVisUV)
3464 if (dtype == SVt_PVGV) {
3465 if (ckWARN(WARN_MISC))
3466 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3469 (void)SvOK_off(dstr);
3471 if (SvTAINTED(sstr))
3476 =for apidoc sv_setsv_mg
3478 Like C<sv_setsv>, but also handles 'set' magic.
3484 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3486 sv_setsv(dstr,sstr);
3491 =for apidoc sv_setpvn
3493 Copies a string into an SV. The C<len> parameter indicates the number of
3494 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3500 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3502 register char *dptr;
3504 /* len is STRLEN which is unsigned, need to copy to signed */
3508 SV_CHECK_THINKFIRST(sv);
3513 (void)SvUPGRADE(sv, SVt_PV);
3515 SvGROW(sv, len + 1);
3517 Move(ptr,dptr,len,char);
3520 (void)SvPOK_only(sv); /* validate pointer */
3525 =for apidoc sv_setpvn_mg
3527 Like C<sv_setpvn>, but also handles 'set' magic.
3533 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3535 sv_setpvn(sv,ptr,len);
3540 =for apidoc sv_setpv
3542 Copies a string into an SV. The string must be null-terminated. Does not
3543 handle 'set' magic. See C<sv_setpv_mg>.
3549 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3551 register STRLEN len;
3553 SV_CHECK_THINKFIRST(sv);
3559 (void)SvUPGRADE(sv, SVt_PV);
3561 SvGROW(sv, len + 1);
3562 Move(ptr,SvPVX(sv),len+1,char);
3564 (void)SvPOK_only(sv); /* validate pointer */
3569 =for apidoc sv_setpv_mg
3571 Like C<sv_setpv>, but also handles 'set' magic.
3577 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3584 =for apidoc sv_usepvn
3586 Tells an SV to use C<ptr> to find its string value. Normally the string is
3587 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3588 The C<ptr> should point to memory that was allocated by C<malloc>. The
3589 string length, C<len>, must be supplied. This function will realloc the
3590 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3591 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3592 See C<sv_usepvn_mg>.
3598 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3600 SV_CHECK_THINKFIRST(sv);
3601 (void)SvUPGRADE(sv, SVt_PV);
3606 (void)SvOOK_off(sv);
3607 if (SvPVX(sv) && SvLEN(sv))
3608 Safefree(SvPVX(sv));
3609 Renew(ptr, len+1, char);
3612 SvLEN_set(sv, len+1);
3614 (void)SvPOK_only(sv); /* validate pointer */
3619 =for apidoc sv_usepvn_mg
3621 Like C<sv_usepvn>, but also handles 'set' magic.
3627 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3629 sv_usepvn(sv,ptr,len);
3634 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3636 if (SvREADONLY(sv)) {
3638 char *pvx = SvPVX(sv);
3639 STRLEN len = SvCUR(sv);
3640 U32 hash = SvUVX(sv);
3641 SvGROW(sv, len + 1);
3642 Move(pvx,SvPVX(sv),len,char);
3646 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3648 else if (PL_curcop != &PL_compiling)
3649 Perl_croak(aTHX_ PL_no_modify);
3652 sv_unref_flags(sv, flags);
3653 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3658 Perl_sv_force_normal(pTHX_ register SV *sv)
3660 sv_force_normal_flags(sv, 0);
3666 Efficient removal of characters from the beginning of the string buffer.
3667 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3668 the string buffer. The C<ptr> becomes the first character of the adjusted
3675 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3679 register STRLEN delta;
3681 if (!ptr || !SvPOKp(sv))
3683 SV_CHECK_THINKFIRST(sv);
3684 if (SvTYPE(sv) < SVt_PVIV)
3685 sv_upgrade(sv,SVt_PVIV);
3688 if (!SvLEN(sv)) { /* make copy of shared string */
3689 char *pvx = SvPVX(sv);
3690 STRLEN len = SvCUR(sv);
3691 SvGROW(sv, len + 1);
3692 Move(pvx,SvPVX(sv),len,char);
3696 SvFLAGS(sv) |= SVf_OOK;
3698 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3699 delta = ptr - SvPVX(sv);
3707 =for apidoc sv_catpvn
3709 Concatenates the string onto the end of the string which is in the SV. The
3710 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3711 'set' magic. See C<sv_catpvn_mg>.
3717 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3722 junk = SvPV_force(sv, tlen);
3723 SvGROW(sv, tlen + len + 1);
3726 Move(ptr,SvPVX(sv)+tlen,len,char);
3729 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3734 =for apidoc sv_catpvn_mg
3736 Like C<sv_catpvn>, but also handles 'set' magic.
3742 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3744 sv_catpvn(sv,ptr,len);
3749 =for apidoc sv_catsv
3751 Concatenates the string from SV C<ssv> onto the end of the string in
3752 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3753 not 'set' magic. See C<sv_catsv_mg>.
3758 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3764 if ((spv = SvPV(sstr, slen))) {
3765 bool dutf8 = DO_UTF8(dstr);
3766 bool sutf8 = DO_UTF8(sstr);
3769 sv_catpvn(dstr,spv,slen);
3772 SV* cstr = newSVsv(sstr);
3776 sv_utf8_upgrade(cstr);
3777 cpv = SvPV(cstr,clen);
3778 sv_catpvn(dstr,cpv,clen);
3782 sv_utf8_upgrade(dstr);
3783 sv_catpvn(dstr,spv,slen);
3791 =for apidoc sv_catsv_mg
3793 Like C<sv_catsv>, but also handles 'set' magic.
3799 Perl_sv_catsv_mg(pTHX_ SV *dstr, register SV *sstr)
3801 sv_catsv(dstr,sstr);
3806 =for apidoc sv_catpv
3808 Concatenates the string onto the end of the string which is in the SV.
3809 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3815 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3817 register STRLEN len;
3823 junk = SvPV_force(sv, tlen);
3825 SvGROW(sv, tlen + len + 1);
3828 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3830 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3835 =for apidoc sv_catpv_mg
3837 Like C<sv_catpv>, but also handles 'set' magic.
3843 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3850 Perl_newSV(pTHX_ STRLEN len)
3856 sv_upgrade(sv, SVt_PV);
3857 SvGROW(sv, len + 1);
3862 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3865 =for apidoc sv_magic
3867 Adds magic to an SV.
3873 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3877 if (SvREADONLY(sv)) {
3878 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3879 Perl_croak(aTHX_ PL_no_modify);
3881 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3882 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3889 (void)SvUPGRADE(sv, SVt_PVMG);
3891 Newz(702,mg, 1, MAGIC);
3892 mg->mg_moremagic = SvMAGIC(sv);
3895 if (!obj || obj == sv || how == '#' || how == 'r')
3898 mg->mg_obj = SvREFCNT_inc(obj);
3899 mg->mg_flags |= MGf_REFCOUNTED;
3902 mg->mg_len = namlen;
3905 mg->mg_ptr = savepvn(name, namlen);
3906 else if (namlen == HEf_SVKEY)
3907 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3911 mg->mg_virtual = &PL_vtbl_sv;
3914 mg->mg_virtual = &PL_vtbl_amagic;
3917 mg->mg_virtual = &PL_vtbl_amagicelem;
3923 mg->mg_virtual = &PL_vtbl_bm;
3926 mg->mg_virtual = &PL_vtbl_regdata;
3929 mg->mg_virtual = &PL_vtbl_regdatum;
3932 mg->mg_virtual = &PL_vtbl_env;
3935 mg->mg_virtual = &PL_vtbl_fm;
3938 mg->mg_virtual = &PL_vtbl_envelem;
3941 mg->mg_virtual = &PL_vtbl_mglob;
3944 mg->mg_virtual = &PL_vtbl_isa;
3947 mg->mg_virtual = &PL_vtbl_isaelem;
3950 mg->mg_virtual = &PL_vtbl_nkeys;
3957 mg->mg_virtual = &PL_vtbl_dbline;
3961 mg->mg_virtual = &PL_vtbl_mutex;
3963 #endif /* USE_THREADS */
3964 #ifdef USE_LOCALE_COLLATE
3966 mg->mg_virtual = &PL_vtbl_collxfrm;
3968 #endif /* USE_LOCALE_COLLATE */
3970 mg->mg_virtual = &PL_vtbl_pack;
3974 mg->mg_virtual = &PL_vtbl_packelem;
3977 mg->mg_virtual = &PL_vtbl_regexp;
3980 mg->mg_virtual = &PL_vtbl_sig;
3983 mg->mg_virtual = &PL_vtbl_sigelem;
3986 mg->mg_virtual = &PL_vtbl_taint;
3990 mg->mg_virtual = &PL_vtbl_uvar;
3993 mg->mg_virtual = &PL_vtbl_vec;
3996 mg->mg_virtual = &PL_vtbl_substr;
3999 mg->mg_virtual = &PL_vtbl_defelem;
4002 mg->mg_virtual = &PL_vtbl_glob;
4005 mg->mg_virtual = &PL_vtbl_arylen;
4008 mg->mg_virtual = &PL_vtbl_pos;
4011 mg->mg_virtual = &PL_vtbl_backref;
4013 case '~': /* Reserved for use by extensions not perl internals. */
4014 /* Useful for attaching extension internal data to perl vars. */
4015 /* Note that multiple extensions may clash if magical scalars */
4016 /* etc holding private data from one are passed to another. */
4020 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4024 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4028 =for apidoc sv_unmagic
4030 Removes magic from an SV.
4036 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4040 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4043 for (mg = *mgp; mg; mg = *mgp) {
4044 if (mg->mg_type == type) {
4045 MGVTBL* vtbl = mg->mg_virtual;
4046 *mgp = mg->mg_moremagic;
4047 if (vtbl && vtbl->svt_free)
4048 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4049 if (mg->mg_ptr && mg->mg_type != 'g')
4050 if (mg->mg_len >= 0)
4051 Safefree(mg->mg_ptr);
4052 else if (mg->mg_len == HEf_SVKEY)
4053 SvREFCNT_dec((SV*)mg->mg_ptr);
4054 if (mg->mg_flags & MGf_REFCOUNTED)
4055 SvREFCNT_dec(mg->mg_obj);
4059 mgp = &mg->mg_moremagic;
4063 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4070 =for apidoc sv_rvweaken
4078 Perl_sv_rvweaken(pTHX_ SV *sv)
4081 if (!SvOK(sv)) /* let undefs pass */
4084 Perl_croak(aTHX_ "Can't weaken a nonreference");
4085 else if (SvWEAKREF(sv)) {
4086 if (ckWARN(WARN_MISC))
4087 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4091 sv_add_backref(tsv, sv);
4098 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4102 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4103 av = (AV*)mg->mg_obj;
4106 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4107 SvREFCNT_dec(av); /* for sv_magic */
4113 S_sv_del_backref(pTHX_ SV *sv)
4120 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4121 Perl_croak(aTHX_ "panic: del_backref");
4122 av = (AV *)mg->mg_obj;
4127 svp[i] = &PL_sv_undef; /* XXX */
4134 =for apidoc sv_insert
4136 Inserts a string at the specified offset/length within the SV. Similar to
4137 the Perl substr() function.
4143 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4147 register char *midend;
4148 register char *bigend;
4154 Perl_croak(aTHX_ "Can't modify non-existent substring");
4155 SvPV_force(bigstr, curlen);
4156 (void)SvPOK_only_UTF8(bigstr);
4157 if (offset + len > curlen) {
4158 SvGROW(bigstr, offset+len+1);
4159 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4160 SvCUR_set(bigstr, offset+len);
4164 i = littlelen - len;
4165 if (i > 0) { /* string might grow */
4166 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4167 mid = big + offset + len;
4168 midend = bigend = big + SvCUR(bigstr);
4171 while (midend > mid) /* shove everything down */
4172 *--bigend = *--midend;
4173 Move(little,big+offset,littlelen,char);
4179 Move(little,SvPVX(bigstr)+offset,len,char);
4184 big = SvPVX(bigstr);
4187 bigend = big + SvCUR(bigstr);
4189 if (midend > bigend)
4190 Perl_croak(aTHX_ "panic: sv_insert");
4192 if (mid - big > bigend - midend) { /* faster to shorten from end */
4194 Move(little, mid, littlelen,char);
4197 i = bigend - midend;
4199 Move(midend, mid, i,char);
4203 SvCUR_set(bigstr, mid - big);
4206 else if ((i = mid - big)) { /* faster from front */
4207 midend -= littlelen;
4209 sv_chop(bigstr,midend-i);
4214 Move(little, mid, littlelen,char);
4216 else if (littlelen) {
4217 midend -= littlelen;
4218 sv_chop(bigstr,midend);
4219 Move(little,midend,littlelen,char);
4222 sv_chop(bigstr,midend);
4228 =for apidoc sv_replace
4230 Make the first argument a copy of the second, then delete the original.
4236 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4238 U32 refcnt = SvREFCNT(sv);
4239 SV_CHECK_THINKFIRST(sv);
4240 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4241 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4242 if (SvMAGICAL(sv)) {
4246 sv_upgrade(nsv, SVt_PVMG);
4247 SvMAGIC(nsv) = SvMAGIC(sv);
4248 SvFLAGS(nsv) |= SvMAGICAL(sv);
4254 assert(!SvREFCNT(sv));
4255 StructCopy(nsv,sv,SV);
4256 SvREFCNT(sv) = refcnt;
4257 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4262 =for apidoc sv_clear
4264 Clear an SV, making it empty. Does not free the memory used by the SV
4271 Perl_sv_clear(pTHX_ register SV *sv)
4275 assert(SvREFCNT(sv) == 0);
4278 if (PL_defstash) { /* Still have a symbol table? */
4283 Zero(&tmpref, 1, SV);
4284 sv_upgrade(&tmpref, SVt_RV);
4286 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4287 SvREFCNT(&tmpref) = 1;
4290 stash = SvSTASH(sv);
4291 destructor = StashHANDLER(stash,DESTROY);
4294 PUSHSTACKi(PERLSI_DESTROY);
4295 SvRV(&tmpref) = SvREFCNT_inc(sv);
4300 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4306 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4308 del_XRV(SvANY(&tmpref));
4311 if (PL_in_clean_objs)
4312 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4314 /* DESTROY gave object new lease on life */
4320 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4321 SvOBJECT_off(sv); /* Curse the object. */
4322 if (SvTYPE(sv) != SVt_PVIO)
4323 --PL_sv_objcount; /* XXX Might want something more general */
4326 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4329 switch (SvTYPE(sv)) {
4332 IoIFP(sv) != PerlIO_stdin() &&
4333 IoIFP(sv) != PerlIO_stdout() &&
4334 IoIFP(sv) != PerlIO_stderr())
4336 io_close((IO*)sv, FALSE);
4338 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4339 PerlDir_close(IoDIRP(sv));
4340 IoDIRP(sv) = (DIR*)NULL;
4341 Safefree(IoTOP_NAME(sv));
4342 Safefree(IoFMT_NAME(sv));
4343 Safefree(IoBOTTOM_NAME(sv));
4358 SvREFCNT_dec(LvTARG(sv));
4362 Safefree(GvNAME(sv));
4363 /* cannot decrease stash refcount yet, as we might recursively delete
4364 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4365 of stash until current sv is completely gone.
4366 -- JohnPC, 27 Mar 1998 */
4367 stash = GvSTASH(sv);
4373 (void)SvOOK_off(sv);
4381 SvREFCNT_dec(SvRV(sv));
4383 else if (SvPVX(sv) && SvLEN(sv))
4384 Safefree(SvPVX(sv));
4385 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4386 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4398 switch (SvTYPE(sv)) {
4414 del_XPVIV(SvANY(sv));
4417 del_XPVNV(SvANY(sv));
4420 del_XPVMG(SvANY(sv));
4423 del_XPVLV(SvANY(sv));
4426 del_XPVAV(SvANY(sv));
4429 del_XPVHV(SvANY(sv));
4432 del_XPVCV(SvANY(sv));
4435 del_XPVGV(SvANY(sv));
4436 /* code duplication for increased performance. */
4437 SvFLAGS(sv) &= SVf_BREAK;
4438 SvFLAGS(sv) |= SVTYPEMASK;
4439 /* decrease refcount of the stash that owns this GV, if any */
4441 SvREFCNT_dec(stash);
4442 return; /* not break, SvFLAGS reset already happened */
4444 del_XPVBM(SvANY(sv));
4447 del_XPVFM(SvANY(sv));
4450 del_XPVIO(SvANY(sv));
4453 SvFLAGS(sv) &= SVf_BREAK;
4454 SvFLAGS(sv) |= SVTYPEMASK;
4458 Perl_sv_newref(pTHX_ SV *sv)
4461 ATOMIC_INC(SvREFCNT(sv));
4468 Free the memory used by an SV.
4474 Perl_sv_free(pTHX_ SV *sv)
4476 int refcount_is_zero;
4480 if (SvREFCNT(sv) == 0) {
4481 if (SvFLAGS(sv) & SVf_BREAK)
4483 if (PL_in_clean_all) /* All is fair */
4485 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4486 /* make sure SvREFCNT(sv)==0 happens very seldom */
4487 SvREFCNT(sv) = (~(U32)0)/2;
4490 if (ckWARN_d(WARN_INTERNAL))
4491 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4494 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4495 if (!refcount_is_zero)
4499 if (ckWARN_d(WARN_DEBUGGING))
4500 Perl_warner(aTHX_ WARN_DEBUGGING,
4501 "Attempt to free temp prematurely: SV 0x%"UVxf,
4506 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4507 /* make sure SvREFCNT(sv)==0 happens very seldom */
4508 SvREFCNT(sv) = (~(U32)0)/2;
4519 Returns the length of the string in the SV. See also C<SvCUR>.
4525 Perl_sv_len(pTHX_ register SV *sv)
4534 len = mg_length(sv);
4536 junk = SvPV(sv, len);
4541 =for apidoc sv_len_utf8
4543 Returns the number of characters in the string in an SV, counting wide
4544 UTF8 bytes as a single character.
4550 Perl_sv_len_utf8(pTHX_ register SV *sv)
4556 return mg_length(sv);
4560 U8 *s = (U8*)SvPV(sv, len);
4562 return Perl_utf8_length(aTHX_ s, s + len);
4567 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4572 I32 uoffset = *offsetp;
4578 start = s = (U8*)SvPV(sv, len);
4580 while (s < send && uoffset--)
4584 *offsetp = s - start;
4588 while (s < send && ulen--)
4598 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4607 s = (U8*)SvPV(sv, len);
4609 Perl_croak(aTHX_ "panic: bad byte offset");
4610 send = s + *offsetp;
4617 if (ckWARN_d(WARN_UTF8))
4618 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4628 Returns a boolean indicating whether the strings in the two SVs are
4635 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4642 bool pv1tmp = FALSE;
4643 bool pv2tmp = FALSE;
4650 pv1 = SvPV(sv1, cur1);
4657 pv2 = SvPV(sv2, cur2);
4659 /* do not utf8ize the comparands as a side-effect */
4660 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4662 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4666 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4672 eq = memEQ(pv1, pv2, cur1);
4685 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4686 string in C<sv1> is less than, equal to, or greater than the string in
4693 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4698 bool pv1tmp = FALSE;
4699 bool pv2tmp = FALSE;
4706 pv1 = SvPV(sv1, cur1);
4713 pv2 = SvPV(sv2, cur2);
4715 /* do not utf8ize the comparands as a side-effect */
4716 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4718 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4722 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4728 cmp = cur2 ? -1 : 0;
4732 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4735 cmp = retval < 0 ? -1 : 1;
4736 } else if (cur1 == cur2) {
4739 cmp = cur1 < cur2 ? -1 : 1;
4752 =for apidoc sv_cmp_locale
4754 Compares the strings in two SVs in a locale-aware manner. See
4761 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4763 #ifdef USE_LOCALE_COLLATE
4769 if (PL_collation_standard)
4773 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4775 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4777 if (!pv1 || !len1) {
4788 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4791 return retval < 0 ? -1 : 1;
4794 * When the result of collation is equality, that doesn't mean
4795 * that there are no differences -- some locales exclude some
4796 * characters from consideration. So to avoid false equalities,
4797 * we use the raw string as a tiebreaker.
4803 #endif /* USE_LOCALE_COLLATE */
4805 return sv_cmp(sv1, sv2);
4808 #ifdef USE_LOCALE_COLLATE
4810 * Any scalar variable may carry an 'o' magic that contains the
4811 * scalar data of the variable transformed to such a format that
4812 * a normal memory comparison can be used to compare the data
4813 * according to the locale settings.
4816 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4820 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4821 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4826 Safefree(mg->mg_ptr);
4828 if ((xf = mem_collxfrm(s, len, &xlen))) {
4829 if (SvREADONLY(sv)) {
4832 return xf + sizeof(PL_collation_ix);
4835 sv_magic(sv, 0, 'o', 0, 0);
4836 mg = mg_find(sv, 'o');
4849 if (mg && mg->mg_ptr) {
4851 return mg->mg_ptr + sizeof(PL_collation_ix);
4859 #endif /* USE_LOCALE_COLLATE */
4864 Get a line from the filehandle and store it into the SV, optionally
4865 appending to the currently-stored string.
4871 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4875 register STDCHAR rslast;
4876 register STDCHAR *bp;
4880 SV_CHECK_THINKFIRST(sv);
4881 (void)SvUPGRADE(sv, SVt_PV);
4885 if (RsSNARF(PL_rs)) {
4889 else if (RsRECORD(PL_rs)) {
4890 I32 recsize, bytesread;
4893 /* Grab the size of the record we're getting */
4894 recsize = SvIV(SvRV(PL_rs));
4895 (void)SvPOK_only(sv); /* Validate pointer */
4896 buffer = SvGROW(sv, recsize + 1);
4899 /* VMS wants read instead of fread, because fread doesn't respect */
4900 /* RMS record boundaries. This is not necessarily a good thing to be */
4901 /* doing, but we've got no other real choice */
4902 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4904 bytesread = PerlIO_read(fp, buffer, recsize);
4906 SvCUR_set(sv, bytesread);
4907 buffer[bytesread] = '\0';
4908 if (PerlIO_isutf8(fp))
4912 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4914 else if (RsPARA(PL_rs)) {
4919 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4920 if (PerlIO_isutf8(fp)) {
4921 rsptr = SvPVutf8(PL_rs, rslen);
4924 if (SvUTF8(PL_rs)) {
4925 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4926 Perl_croak(aTHX_ "Wide character in $/");
4929 rsptr = SvPV(PL_rs, rslen);
4933 rslast = rslen ? rsptr[rslen - 1] : '\0';
4935 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4936 do { /* to make sure file boundaries work right */
4939 i = PerlIO_getc(fp);
4943 PerlIO_ungetc(fp,i);
4949 /* See if we know enough about I/O mechanism to cheat it ! */
4951 /* This used to be #ifdef test - it is made run-time test for ease
4952 of abstracting out stdio interface. One call should be cheap
4953 enough here - and may even be a macro allowing compile
4957 if (PerlIO_fast_gets(fp)) {
4960 * We're going to steal some values from the stdio struct
4961 * and put EVERYTHING in the innermost loop into registers.
4963 register STDCHAR *ptr;
4967 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4968 /* An ungetc()d char is handled separately from the regular
4969 * buffer, so we getc() it back out and stuff it in the buffer.
4971 i = PerlIO_getc(fp);
4972 if (i == EOF) return 0;
4973 *(--((*fp)->_ptr)) = (unsigned char) i;
4977 /* Here is some breathtakingly efficient cheating */
4979 cnt = PerlIO_get_cnt(fp); /* get count into register */
4980 (void)SvPOK_only(sv); /* validate pointer */
4981 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
4982 if (cnt > 80 && SvLEN(sv) > append) {
4983 shortbuffered = cnt - SvLEN(sv) + append + 1;
4984 cnt -= shortbuffered;
4988 /* remember that cnt can be negative */
4989 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
4994 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
4995 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
4996 DEBUG_P(PerlIO_printf(Perl_debug_log,
4997 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
4998 DEBUG_P(PerlIO_printf(Perl_debug_log,
4999 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5000 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5001 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5006 while (cnt > 0) { /* this | eat */
5008 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5009 goto thats_all_folks; /* screams | sed :-) */
5013 Copy(ptr, bp, cnt, char); /* this | eat */
5014 bp += cnt; /* screams | dust */
5015 ptr += cnt; /* louder | sed :-) */
5020 if (shortbuffered) { /* oh well, must extend */
5021 cnt = shortbuffered;
5023 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5025 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5026 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5030 DEBUG_P(PerlIO_printf(Perl_debug_log,
5031 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5032 PTR2UV(ptr),(long)cnt));
5033 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5034 DEBUG_P(PerlIO_printf(Perl_debug_log,
5035 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5036 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5037 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5038 /* This used to call 'filbuf' in stdio form, but as that behaves like
5039 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5040 another abstraction. */
5041 i = PerlIO_getc(fp); /* get more characters */
5042 DEBUG_P(PerlIO_printf(Perl_debug_log,
5043 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5044 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5045 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5046 cnt = PerlIO_get_cnt(fp);
5047 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5048 DEBUG_P(PerlIO_printf(Perl_debug_log,
5049 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5051 if (i == EOF) /* all done for ever? */
5052 goto thats_really_all_folks;
5054 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5056 SvGROW(sv, bpx + cnt + 2);
5057 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5059 *bp++ = i; /* store character from PerlIO_getc */
5061 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5062 goto thats_all_folks;
5066 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5067 memNE((char*)bp - rslen, rsptr, rslen))
5068 goto screamer; /* go back to the fray */
5069 thats_really_all_folks:
5071 cnt += shortbuffered;
5072 DEBUG_P(PerlIO_printf(Perl_debug_log,
5073 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5074 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5075 DEBUG_P(PerlIO_printf(Perl_debug_log,
5076 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5077 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5078 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5080 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5081 DEBUG_P(PerlIO_printf(Perl_debug_log,
5082 "Screamer: done, len=%ld, string=|%.*s|\n",
5083 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5088 /*The big, slow, and stupid way */
5091 /* Need to work around EPOC SDK features */
5092 /* On WINS: MS VC5 generates calls to _chkstk, */
5093 /* if a `large' stack frame is allocated */
5094 /* gcc on MARM does not generate calls like these */
5100 register STDCHAR *bpe = buf + sizeof(buf);
5102 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5103 ; /* keep reading */
5107 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5108 /* Accomodate broken VAXC compiler, which applies U8 cast to
5109 * both args of ?: operator, causing EOF to change into 255
5111 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5115 sv_catpvn(sv, (char *) buf, cnt);
5117 sv_setpvn(sv, (char *) buf, cnt);
5119 if (i != EOF && /* joy */
5121 SvCUR(sv) < rslen ||
5122 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5126 * If we're reading from a TTY and we get a short read,
5127 * indicating that the user hit his EOF character, we need
5128 * to notice it now, because if we try to read from the TTY
5129 * again, the EOF condition will disappear.
5131 * The comparison of cnt to sizeof(buf) is an optimization
5132 * that prevents unnecessary calls to feof().
5136 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5141 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5142 while (i != EOF) { /* to make sure file boundaries work right */
5143 i = PerlIO_getc(fp);
5145 PerlIO_ungetc(fp,i);
5151 if (PerlIO_isutf8(fp))
5156 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5163 Auto-increment of the value in the SV.
5169 Perl_sv_inc(pTHX_ register SV *sv)
5178 if (SvTHINKFIRST(sv)) {
5179 if (SvREADONLY(sv)) {
5180 if (PL_curcop != &PL_compiling)
5181 Perl_croak(aTHX_ PL_no_modify);
5185 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5187 i = PTR2IV(SvRV(sv));
5192 flags = SvFLAGS(sv);
5193 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5194 /* It's (privately or publicly) a float, but not tested as an
5195 integer, so test it to see. */
5197 flags = SvFLAGS(sv);
5199 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5200 /* It's publicly an integer, or privately an integer-not-float */
5203 if (SvUVX(sv) == UV_MAX)
5204 sv_setnv(sv, (NV)UV_MAX + 1.0);
5206 (void)SvIOK_only_UV(sv);
5209 if (SvIVX(sv) == IV_MAX)
5210 sv_setuv(sv, (UV)IV_MAX + 1);
5212 (void)SvIOK_only(sv);
5218 if (flags & SVp_NOK) {
5219 (void)SvNOK_only(sv);
5224 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5225 if ((flags & SVTYPEMASK) < SVt_PVIV)
5226 sv_upgrade(sv, SVt_IV);
5227 (void)SvIOK_only(sv);
5232 while (isALPHA(*d)) d++;
5233 while (isDIGIT(*d)) d++;
5235 #ifdef PERL_PRESERVE_IVUV
5236 /* Got to punt this an an integer if needs be, but we don't issue
5237 warnings. Probably ought to make the sv_iv_please() that does
5238 the conversion if possible, and silently. */
5239 I32 numtype = looks_like_number(sv);
5240 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5241 /* Need to try really hard to see if it's an integer.
5242 9.22337203685478e+18 is an integer.
5243 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5244 so $a="9.22337203685478e+18"; $a+0; $a++
5245 needs to be the same as $a="9.22337203685478e+18"; $a++
5252 /* sv_2iv *should* have made this an NV */
5253 if (flags & SVp_NOK) {
5254 (void)SvNOK_only(sv);
5258 /* I don't think we can get here. Maybe I should assert this
5259 And if we do get here I suspect that sv_setnv will croak. NWC
5261 #if defined(USE_LONG_DOUBLE)
5262 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",
5263 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5265 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5266 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5269 #endif /* PERL_PRESERVE_IVUV */
5270 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5274 while (d >= SvPVX(sv)) {
5282 /* MKS: The original code here died if letters weren't consecutive.
5283 * at least it didn't have to worry about non-C locales. The
5284 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5285 * arranged in order (although not consecutively) and that only
5286 * [A-Za-z] are accepted by isALPHA in the C locale.
5288 if (*d != 'z' && *d != 'Z') {
5289 do { ++*d; } while (!isALPHA(*d));
5292 *(d--) -= 'z' - 'a';
5297 *(d--) -= 'z' - 'a' + 1;
5301 /* oh,oh, the number grew */
5302 SvGROW(sv, SvCUR(sv) + 2);
5304 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5315 Auto-decrement of the value in the SV.
5321 Perl_sv_dec(pTHX_ register SV *sv)
5329 if (SvTHINKFIRST(sv)) {
5330 if (SvREADONLY(sv)) {
5331 if (PL_curcop != &PL_compiling)
5332 Perl_croak(aTHX_ PL_no_modify);
5336 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5338 i = PTR2IV(SvRV(sv));
5343 /* Unlike sv_inc we don't have to worry about string-never-numbers
5344 and keeping them magic. But we mustn't warn on punting */
5345 flags = SvFLAGS(sv);
5346 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5347 /* It's publicly an integer, or privately an integer-not-float */
5350 if (SvUVX(sv) == 0) {
5351 (void)SvIOK_only(sv);
5355 (void)SvIOK_only_UV(sv);
5359 if (SvIVX(sv) == IV_MIN)
5360 sv_setnv(sv, (NV)IV_MIN - 1.0);
5362 (void)SvIOK_only(sv);
5368 if (flags & SVp_NOK) {
5370 (void)SvNOK_only(sv);
5373 if (!(flags & SVp_POK)) {
5374 if ((flags & SVTYPEMASK) < SVt_PVNV)
5375 sv_upgrade(sv, SVt_NV);
5377 (void)SvNOK_only(sv);
5380 #ifdef PERL_PRESERVE_IVUV
5382 I32 numtype = looks_like_number(sv);
5383 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5384 /* Need to try really hard to see if it's an integer.
5385 9.22337203685478e+18 is an integer.
5386 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5387 so $a="9.22337203685478e+18"; $a+0; $a--
5388 needs to be the same as $a="9.22337203685478e+18"; $a--
5395 /* sv_2iv *should* have made this an NV */
5396 if (flags & SVp_NOK) {
5397 (void)SvNOK_only(sv);
5401 /* I don't think we can get here. Maybe I should assert this
5402 And if we do get here I suspect that sv_setnv will croak. NWC
5404 #if defined(USE_LONG_DOUBLE)
5405 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",
5406 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5408 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5409 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5413 #endif /* PERL_PRESERVE_IVUV */
5414 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5418 =for apidoc sv_mortalcopy
5420 Creates a new SV which is a copy of the original SV. The new SV is marked
5426 /* Make a string that will exist for the duration of the expression
5427 * evaluation. Actually, it may have to last longer than that, but
5428 * hopefully we won't free it until it has been assigned to a
5429 * permanent location. */
5432 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5437 sv_setsv(sv,oldstr);
5439 PL_tmps_stack[++PL_tmps_ix] = sv;
5445 =for apidoc sv_newmortal
5447 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5453 Perl_sv_newmortal(pTHX)
5458 SvFLAGS(sv) = SVs_TEMP;
5460 PL_tmps_stack[++PL_tmps_ix] = sv;
5465 =for apidoc sv_2mortal
5467 Marks an SV as mortal. The SV will be destroyed when the current context
5473 /* same thing without the copying */
5476 Perl_sv_2mortal(pTHX_ register SV *sv)
5480 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5483 PL_tmps_stack[++PL_tmps_ix] = sv;
5491 Creates a new SV and copies a string into it. The reference count for the
5492 SV is set to 1. If C<len> is zero, Perl will compute the length using
5493 strlen(). For efficiency, consider using C<newSVpvn> instead.
5499 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5506 sv_setpvn(sv,s,len);
5511 =for apidoc newSVpvn
5513 Creates a new SV and copies a string into it. The reference count for the
5514 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5515 string. You are responsible for ensuring that the source string is at least
5522 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5527 sv_setpvn(sv,s,len);
5532 =for apidoc newSVpvn_share
5534 Creates a new SV and populates it with a string from
5535 the string table. Turns on READONLY and FAKE.
5536 The idea here is that as string table is used for shared hash
5537 keys these strings will have SvPVX == HeKEY and hash lookup
5538 will avoid string compare.
5544 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5547 bool is_utf8 = FALSE;
5553 PERL_HASH(hash, src, len);
5555 sv_upgrade(sv, SVt_PVIV);
5556 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5568 #if defined(PERL_IMPLICIT_CONTEXT)
5570 Perl_newSVpvf_nocontext(const char* pat, ...)
5575 va_start(args, pat);
5576 sv = vnewSVpvf(pat, &args);
5583 =for apidoc newSVpvf
5585 Creates a new SV an initialize it with the string formatted like
5592 Perl_newSVpvf(pTHX_ const char* pat, ...)
5596 va_start(args, pat);
5597 sv = vnewSVpvf(pat, &args);
5603 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5607 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5614 Creates a new SV and copies a floating point value into it.
5615 The reference count for the SV is set to 1.
5621 Perl_newSVnv(pTHX_ NV n)
5633 Creates a new SV and copies an integer into it. The reference count for the
5640 Perl_newSViv(pTHX_ IV i)
5652 Creates a new SV and copies an unsigned integer into it.
5653 The reference count for the SV is set to 1.
5659 Perl_newSVuv(pTHX_ UV u)
5669 =for apidoc newRV_noinc
5671 Creates an RV wrapper for an SV. The reference count for the original
5672 SV is B<not> incremented.
5678 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5683 sv_upgrade(sv, SVt_RV);
5690 /* newRV_inc is #defined to newRV in sv.h */
5692 Perl_newRV(pTHX_ SV *tmpRef)
5694 return newRV_noinc(SvREFCNT_inc(tmpRef));
5700 Creates a new SV which is an exact duplicate of the original SV.
5705 /* make an exact duplicate of old */
5708 Perl_newSVsv(pTHX_ register SV *old)
5714 if (SvTYPE(old) == SVTYPEMASK) {
5715 if (ckWARN_d(WARN_INTERNAL))
5716 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5731 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5739 char todo[PERL_UCHAR_MAX+1];
5744 if (!*s) { /* reset ?? searches */
5745 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5746 pm->op_pmdynflags &= ~PMdf_USED;
5751 /* reset variables */
5753 if (!HvARRAY(stash))
5756 Zero(todo, 256, char);
5758 i = (unsigned char)*s;
5762 max = (unsigned char)*s++;
5763 for ( ; i <= max; i++) {
5766 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5767 for (entry = HvARRAY(stash)[i];
5769 entry = HeNEXT(entry))
5771 if (!todo[(U8)*HeKEY(entry)])
5773 gv = (GV*)HeVAL(entry);
5775 if (SvTHINKFIRST(sv)) {
5776 if (!SvREADONLY(sv) && SvROK(sv))
5781 if (SvTYPE(sv) >= SVt_PV) {
5783 if (SvPVX(sv) != Nullch)
5790 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5792 #ifdef USE_ENVIRON_ARRAY
5794 environ[0] = Nullch;
5803 Perl_sv_2io(pTHX_ SV *sv)
5809 switch (SvTYPE(sv)) {
5817 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5821 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5823 return sv_2io(SvRV(sv));
5824 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5830 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5837 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5844 return *gvp = Nullgv, Nullcv;
5845 switch (SvTYPE(sv)) {
5864 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5865 tryAMAGICunDEREF(to_cv);
5868 if (SvTYPE(sv) == SVt_PVCV) {
5877 Perl_croak(aTHX_ "Not a subroutine reference");
5882 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5888 if (lref && !GvCVu(gv)) {
5891 tmpsv = NEWSV(704,0);
5892 gv_efullname3(tmpsv, gv, Nullch);
5893 /* XXX this is probably not what they think they're getting.
5894 * It has the same effect as "sub name;", i.e. just a forward
5896 newSUB(start_subparse(FALSE, 0),
5897 newSVOP(OP_CONST, 0, tmpsv),
5902 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5911 Returns true if the SV has a true value by Perl's rules.
5917 Perl_sv_true(pTHX_ register SV *sv)
5923 if ((tXpv = (XPV*)SvANY(sv)) &&
5924 (tXpv->xpv_cur > 1 ||
5925 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5932 return SvIVX(sv) != 0;
5935 return SvNVX(sv) != 0.0;
5937 return sv_2bool(sv);
5943 Perl_sv_iv(pTHX_ register SV *sv)
5947 return (IV)SvUVX(sv);
5954 Perl_sv_uv(pTHX_ register SV *sv)
5959 return (UV)SvIVX(sv);
5965 Perl_sv_nv(pTHX_ register SV *sv)
5973 Perl_sv_pv(pTHX_ SV *sv)
5980 return sv_2pv(sv, &n_a);
5984 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
5990 return sv_2pv(sv, lp);
5994 =for apidoc sv_pvn_force
5996 Get a sensible string out of the SV somehow.
6002 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6006 if (SvTHINKFIRST(sv) && !SvROK(sv))
6007 sv_force_normal(sv);
6013 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6014 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6015 PL_op_name[PL_op->op_type]);
6019 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6024 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6025 SvGROW(sv, len + 1);
6026 Move(s,SvPVX(sv),len,char);
6031 SvPOK_on(sv); /* validate pointer */
6033 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6034 PTR2UV(sv),SvPVX(sv)));
6041 Perl_sv_pvbyte(pTHX_ SV *sv)
6047 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6049 return sv_pvn(sv,lp);
6053 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6055 return sv_pvn_force(sv,lp);
6059 Perl_sv_pvutf8(pTHX_ SV *sv)
6061 sv_utf8_upgrade(sv);
6066 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6068 sv_utf8_upgrade(sv);
6069 return sv_pvn(sv,lp);
6073 =for apidoc sv_pvutf8n_force
6075 Get a sensible UTF8-encoded string out of the SV somehow. See
6082 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6084 sv_utf8_upgrade(sv);
6085 return sv_pvn_force(sv,lp);
6089 =for apidoc sv_reftype
6091 Returns a string describing what the SV is a reference to.
6097 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6099 if (ob && SvOBJECT(sv))
6100 return HvNAME(SvSTASH(sv));
6102 switch (SvTYPE(sv)) {
6116 case SVt_PVLV: return "LVALUE";
6117 case SVt_PVAV: return "ARRAY";
6118 case SVt_PVHV: return "HASH";
6119 case SVt_PVCV: return "CODE";
6120 case SVt_PVGV: return "GLOB";
6121 case SVt_PVFM: return "FORMAT";
6122 case SVt_PVIO: return "IO";
6123 default: return "UNKNOWN";
6129 =for apidoc sv_isobject
6131 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6132 object. If the SV is not an RV, or if the object is not blessed, then this
6139 Perl_sv_isobject(pTHX_ SV *sv)
6156 Returns a boolean indicating whether the SV is blessed into the specified
6157 class. This does not check for subtypes; use C<sv_derived_from> to verify
6158 an inheritance relationship.
6164 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6176 return strEQ(HvNAME(SvSTASH(sv)), name);
6182 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6183 it will be upgraded to one. If C<classname> is non-null then the new SV will
6184 be blessed in the specified package. The new SV is returned and its
6185 reference count is 1.
6191 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6197 SV_CHECK_THINKFIRST(rv);
6200 if (SvTYPE(rv) >= SVt_PVMG) {
6201 U32 refcnt = SvREFCNT(rv);
6205 SvREFCNT(rv) = refcnt;
6208 if (SvTYPE(rv) < SVt_RV)
6209 sv_upgrade(rv, SVt_RV);
6210 else if (SvTYPE(rv) > SVt_RV) {
6211 (void)SvOOK_off(rv);
6212 if (SvPVX(rv) && SvLEN(rv))
6213 Safefree(SvPVX(rv));
6223 HV* stash = gv_stashpv(classname, TRUE);
6224 (void)sv_bless(rv, stash);
6230 =for apidoc sv_setref_pv
6232 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6233 argument will be upgraded to an RV. That RV will be modified to point to
6234 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6235 into the SV. The C<classname> argument indicates the package for the
6236 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6237 will be returned and will have a reference count of 1.
6239 Do not use with other Perl types such as HV, AV, SV, CV, because those
6240 objects will become corrupted by the pointer copy process.
6242 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6248 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6251 sv_setsv(rv, &PL_sv_undef);
6255 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6260 =for apidoc sv_setref_iv
6262 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6263 argument will be upgraded to an RV. That RV will be modified to point to
6264 the new SV. The C<classname> argument indicates the package for the
6265 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6266 will be returned and will have a reference count of 1.
6272 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6274 sv_setiv(newSVrv(rv,classname), iv);
6279 =for apidoc sv_setref_nv
6281 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6282 argument will be upgraded to an RV. That RV will be modified to point to
6283 the new SV. The C<classname> argument indicates the package for the
6284 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6285 will be returned and will have a reference count of 1.
6291 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6293 sv_setnv(newSVrv(rv,classname), nv);
6298 =for apidoc sv_setref_pvn
6300 Copies a string into a new SV, optionally blessing the SV. The length of the
6301 string must be specified with C<n>. The C<rv> argument will be upgraded to
6302 an RV. That RV will be modified to point to the new SV. The C<classname>
6303 argument indicates the package for the blessing. Set C<classname> to
6304 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6305 a reference count of 1.
6307 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6313 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6315 sv_setpvn(newSVrv(rv,classname), pv, n);
6320 =for apidoc sv_bless
6322 Blesses an SV into a specified package. The SV must be an RV. The package
6323 must be designated by its stash (see C<gv_stashpv()>). The reference count
6324 of the SV is unaffected.
6330 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6334 Perl_croak(aTHX_ "Can't bless non-reference value");
6336 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6337 if (SvREADONLY(tmpRef))
6338 Perl_croak(aTHX_ PL_no_modify);
6339 if (SvOBJECT(tmpRef)) {
6340 if (SvTYPE(tmpRef) != SVt_PVIO)
6342 SvREFCNT_dec(SvSTASH(tmpRef));
6345 SvOBJECT_on(tmpRef);
6346 if (SvTYPE(tmpRef) != SVt_PVIO)
6348 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6349 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6360 S_sv_unglob(pTHX_ SV *sv)
6364 assert(SvTYPE(sv) == SVt_PVGV);
6369 SvREFCNT_dec(GvSTASH(sv));
6370 GvSTASH(sv) = Nullhv;
6372 sv_unmagic(sv, '*');
6373 Safefree(GvNAME(sv));
6376 /* need to keep SvANY(sv) in the right arena */
6377 xpvmg = new_XPVMG();
6378 StructCopy(SvANY(sv), xpvmg, XPVMG);
6379 del_XPVGV(SvANY(sv));
6382 SvFLAGS(sv) &= ~SVTYPEMASK;
6383 SvFLAGS(sv) |= SVt_PVMG;
6387 =for apidoc sv_unref_flags
6389 Unsets the RV status of the SV, and decrements the reference count of
6390 whatever was being referenced by the RV. This can almost be thought of
6391 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6392 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6393 (otherwise the decrementing is conditional on the reference count being
6394 different from one or the reference being a readonly SV).
6401 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6405 if (SvWEAKREF(sv)) {
6413 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6415 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6416 sv_2mortal(rv); /* Schedule for freeing later */
6420 =for apidoc sv_unref
6422 Unsets the RV status of the SV, and decrements the reference count of
6423 whatever was being referenced by the RV. This can almost be thought of
6424 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6425 being zero. See C<SvROK_off>.
6431 Perl_sv_unref(pTHX_ SV *sv)
6433 sv_unref_flags(sv, 0);
6437 Perl_sv_taint(pTHX_ SV *sv)
6439 sv_magic((sv), Nullsv, 't', Nullch, 0);
6443 Perl_sv_untaint(pTHX_ SV *sv)
6445 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6446 MAGIC *mg = mg_find(sv, 't');
6453 Perl_sv_tainted(pTHX_ SV *sv)
6455 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6456 MAGIC *mg = mg_find(sv, 't');
6457 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6464 =for apidoc sv_setpviv
6466 Copies an integer into the given SV, also updating its string value.
6467 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6473 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6475 char buf[TYPE_CHARS(UV)];
6477 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6479 sv_setpvn(sv, ptr, ebuf - ptr);
6484 =for apidoc sv_setpviv_mg
6486 Like C<sv_setpviv>, but also handles 'set' magic.
6492 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6494 char buf[TYPE_CHARS(UV)];
6496 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6498 sv_setpvn(sv, ptr, ebuf - ptr);
6502 #if defined(PERL_IMPLICIT_CONTEXT)
6504 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6508 va_start(args, pat);
6509 sv_vsetpvf(sv, pat, &args);
6515 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6519 va_start(args, pat);
6520 sv_vsetpvf_mg(sv, pat, &args);
6526 =for apidoc sv_setpvf
6528 Processes its arguments like C<sprintf> and sets an SV to the formatted
6529 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6535 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6538 va_start(args, pat);
6539 sv_vsetpvf(sv, pat, &args);
6544 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6546 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6550 =for apidoc sv_setpvf_mg
6552 Like C<sv_setpvf>, but also handles 'set' magic.
6558 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6561 va_start(args, pat);
6562 sv_vsetpvf_mg(sv, pat, &args);
6567 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6569 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6573 #if defined(PERL_IMPLICIT_CONTEXT)
6575 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6579 va_start(args, pat);
6580 sv_vcatpvf(sv, pat, &args);
6585 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6589 va_start(args, pat);
6590 sv_vcatpvf_mg(sv, pat, &args);
6596 =for apidoc sv_catpvf
6598 Processes its arguments like C<sprintf> and appends the formatted output
6599 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6600 typically be called after calling this function to handle 'set' magic.
6606 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6609 va_start(args, pat);
6610 sv_vcatpvf(sv, pat, &args);
6615 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6617 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6621 =for apidoc sv_catpvf_mg
6623 Like C<sv_catpvf>, but also handles 'set' magic.
6629 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6632 va_start(args, pat);
6633 sv_vcatpvf_mg(sv, pat, &args);
6638 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6640 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6645 =for apidoc sv_vsetpvfn
6647 Works like C<vcatpvfn> but copies the text into the SV instead of
6654 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6656 sv_setpvn(sv, "", 0);
6657 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6661 =for apidoc sv_vcatpvfn
6663 Processes its arguments like C<vsprintf> and appends the formatted output
6664 to an SV. Uses an array of SVs if the C style variable argument list is
6665 missing (NULL). When running with taint checks enabled, indicates via
6666 C<maybe_tainted> if results are untrustworthy (often due to the use of
6673 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6680 static char nullstr[] = "(null)";
6683 /* no matter what, this is a string now */
6684 (void)SvPV_force(sv, origlen);
6686 /* special-case "", "%s", and "%_" */
6689 if (patlen == 2 && pat[0] == '%') {
6693 char *s = va_arg(*args, char*);
6694 sv_catpv(sv, s ? s : nullstr);
6696 else if (svix < svmax) {
6697 sv_catsv(sv, *svargs);
6698 if (DO_UTF8(*svargs))
6704 argsv = va_arg(*args, SV*);
6705 sv_catsv(sv, argsv);
6710 /* See comment on '_' below */
6715 patend = (char*)pat + patlen;
6716 for (p = (char*)pat; p < patend; p = q) {
6719 bool vectorize = FALSE;
6726 bool has_precis = FALSE;
6728 bool is_utf = FALSE;
6731 U8 utf8buf[UTF8_MAXLEN+1];
6732 STRLEN esignlen = 0;
6734 char *eptr = Nullch;
6736 /* Times 4: a decimal digit takes more than 3 binary digits.
6737 * NV_DIG: mantissa takes than many decimal digits.
6738 * Plus 32: Playing safe. */
6739 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6740 /* large enough for "%#.#f" --chip */
6741 /* what about long double NVs? --jhi */
6744 U8 *vecstr = Null(U8*);
6756 STRLEN dotstrlen = 1;
6757 I32 epix = 0; /* explicit parameter index */
6758 I32 ewix = 0; /* explicit width index */
6759 bool asterisk = FALSE;
6761 for (q = p; q < patend && *q != '%'; ++q) ;
6763 sv_catpvn(sv, p, q - p);
6792 case '*': /* printf("%*vX",":",$ipv6addr) */
6797 vecsv = va_arg(*args, SV*);
6798 else if (svix < svmax)
6799 vecsv = svargs[svix++];
6802 dotstr = SvPVx(vecsv,dotstrlen);
6830 case '1': case '2': case '3':
6831 case '4': case '5': case '6':
6832 case '7': case '8': case '9':
6835 width = width * 10 + (*q++ - '0');
6837 if (asterisk && ewix == 0) {
6842 } else if (epix == 0) {
6854 i = va_arg(*args, int);
6856 i = (ewix ? ewix <= svmax : svix < svmax) ?
6857 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6859 width = (i < 0) ? -i : i;
6868 i = va_arg(*args, int);
6870 i = (ewix ? ewix <= svmax : svix < svmax)
6871 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6872 precis = (i < 0) ? 0 : i;
6878 precis = precis * 10 + (*q++ - '0');
6885 vecsv = va_arg(*args, SV*);
6886 vecstr = (U8*)SvPVx(vecsv,veclen);
6887 utf = DO_UTF8(vecsv);
6889 else if (epix ? epix <= svmax : svix < svmax) {
6890 vecsv = svargs[epix ? epix-1 : svix++];
6891 vecstr = (U8*)SvPVx(vecsv,veclen);
6892 utf = DO_UTF8(vecsv);
6903 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6914 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6915 if (*(q + 1) == 'l') { /* lld, llf */
6942 uv = va_arg(*args, int);
6944 uv = (epix ? epix <= svmax : svix < svmax) ?
6945 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6946 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6947 eptr = (char*)utf8buf;
6948 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6960 eptr = va_arg(*args, char*);
6962 #ifdef MACOS_TRADITIONAL
6963 /* On MacOS, %#s format is used for Pascal strings */
6968 elen = strlen(eptr);
6971 elen = sizeof nullstr - 1;
6974 else if (epix ? epix <= svmax : svix < svmax) {
6975 argsv = svargs[epix ? epix-1 : svix++];
6976 eptr = SvPVx(argsv, elen);
6977 if (DO_UTF8(argsv)) {
6978 if (has_precis && precis < elen) {
6980 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
6983 if (width) { /* fudge width (can't fudge elen) */
6984 width += elen - sv_len_utf8(argsv);
6993 * The "%_" hack might have to be changed someday,
6994 * if ISO or ANSI decide to use '_' for something.
6995 * So we keep it hidden from users' code.
6999 argsv = va_arg(*args,SV*);
7000 eptr = SvPVx(argsv, elen);
7006 if (has_precis && elen > precis)
7016 uv = PTR2UV(va_arg(*args, void*));
7018 uv = (epix ? epix <= svmax : svix < svmax) ?
7019 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
7039 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7049 case 'h': iv = (short)va_arg(*args, int); break;
7050 default: iv = va_arg(*args, int); break;
7051 case 'l': iv = va_arg(*args, long); break;
7052 case 'V': iv = va_arg(*args, IV); break;
7054 case 'q': iv = va_arg(*args, Quad_t); break;
7059 iv = (epix ? epix <= svmax : svix < svmax) ?
7060 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
7062 case 'h': iv = (short)iv; break;
7064 case 'l': iv = (long)iv; break;
7067 case 'q': iv = (Quad_t)iv; break;
7074 esignbuf[esignlen++] = plus;
7078 esignbuf[esignlen++] = '-';
7122 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7132 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7133 default: uv = va_arg(*args, unsigned); break;
7134 case 'l': uv = va_arg(*args, unsigned long); break;
7135 case 'V': uv = va_arg(*args, UV); break;
7137 case 'q': uv = va_arg(*args, Quad_t); break;
7142 uv = (epix ? epix <= svmax : svix < svmax) ?
7143 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
7145 case 'h': uv = (unsigned short)uv; break;
7147 case 'l': uv = (unsigned long)uv; break;
7150 case 'q': uv = (Quad_t)uv; break;
7156 eptr = ebuf + sizeof ebuf;
7162 p = (char*)((c == 'X')
7163 ? "0123456789ABCDEF" : "0123456789abcdef");
7169 esignbuf[esignlen++] = '0';
7170 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7176 *--eptr = '0' + dig;
7178 if (alt && *eptr != '0')
7184 *--eptr = '0' + dig;
7187 esignbuf[esignlen++] = '0';
7188 esignbuf[esignlen++] = 'b';
7191 default: /* it had better be ten or less */
7192 #if defined(PERL_Y2KWARN)
7193 if (ckWARN(WARN_Y2K)) {
7195 char *s = SvPV(sv,n);
7196 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7197 && (n == 2 || !isDIGIT(s[n-3])))
7199 Perl_warner(aTHX_ WARN_Y2K,
7200 "Possible Y2K bug: %%%c %s",
7201 c, "format string following '19'");
7207 *--eptr = '0' + dig;
7208 } while (uv /= base);
7211 elen = (ebuf + sizeof ebuf) - eptr;
7214 zeros = precis - elen;
7215 else if (precis == 0 && elen == 1 && *eptr == '0')
7220 /* FLOATING POINT */
7223 c = 'f'; /* maybe %F isn't supported here */
7229 /* This is evil, but floating point is even more evil */
7233 nv = va_arg(*args, NV);
7235 nv = (epix ? epix <= svmax : svix < svmax) ?
7236 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
7239 if (c != 'e' && c != 'E') {
7241 (void)Perl_frexp(nv, &i);
7242 if (i == PERL_INT_MIN)
7243 Perl_die(aTHX_ "panic: frexp");
7245 need = BIT_DIGITS(i);
7247 need += has_precis ? precis : 6; /* known default */
7251 need += 20; /* fudge factor */
7252 if (PL_efloatsize < need) {
7253 Safefree(PL_efloatbuf);
7254 PL_efloatsize = need + 20; /* more fudge */
7255 New(906, PL_efloatbuf, PL_efloatsize, char);
7256 PL_efloatbuf[0] = '\0';
7259 eptr = ebuf + sizeof ebuf;
7262 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7264 /* Copy the one or more characters in a long double
7265 * format before the 'base' ([efgEFG]) character to
7266 * the format string. */
7267 static char const prifldbl[] = PERL_PRIfldbl;
7268 char const *p = prifldbl + sizeof(prifldbl) - 3;
7269 while (p >= prifldbl) { *--eptr = *p--; }
7274 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7279 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7291 /* No taint. Otherwise we are in the strange situation
7292 * where printf() taints but print($float) doesn't.
7294 (void)sprintf(PL_efloatbuf, eptr, nv);
7296 eptr = PL_efloatbuf;
7297 elen = strlen(PL_efloatbuf);
7304 i = SvCUR(sv) - origlen;
7307 case 'h': *(va_arg(*args, short*)) = i; break;
7308 default: *(va_arg(*args, int*)) = i; break;
7309 case 'l': *(va_arg(*args, long*)) = i; break;
7310 case 'V': *(va_arg(*args, IV*)) = i; break;
7312 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7316 else if (epix ? epix <= svmax : svix < svmax)
7317 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
7318 continue; /* not "break" */
7325 if (!args && ckWARN(WARN_PRINTF) &&
7326 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7327 SV *msg = sv_newmortal();
7328 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7329 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7332 Perl_sv_catpvf(aTHX_ msg,
7333 "\"%%%c\"", c & 0xFF);
7335 Perl_sv_catpvf(aTHX_ msg,
7336 "\"%%\\%03"UVof"\"",
7339 sv_catpv(msg, "end of string");
7340 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7343 /* output mangled stuff ... */
7349 /* ... right here, because formatting flags should not apply */
7350 SvGROW(sv, SvCUR(sv) + elen + 1);
7352 memcpy(p, eptr, elen);
7355 SvCUR(sv) = p - SvPVX(sv);
7356 continue; /* not "break" */
7359 have = esignlen + zeros + elen;
7360 need = (have > width ? have : width);
7363 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7365 if (esignlen && fill == '0') {
7366 for (i = 0; i < esignlen; i++)
7370 memset(p, fill, gap);
7373 if (esignlen && fill != '0') {
7374 for (i = 0; i < esignlen; i++)
7378 for (i = zeros; i; i--)
7382 memcpy(p, eptr, elen);
7386 memset(p, ' ', gap);
7391 memcpy(p, dotstr, dotstrlen);
7395 vectorize = FALSE; /* done iterating over vecstr */
7400 SvCUR(sv) = p - SvPVX(sv);
7408 #if defined(USE_ITHREADS)
7410 #if defined(USE_THREADS)
7411 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7414 #ifndef GpREFCNT_inc
7415 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7419 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7420 #define av_dup(s) (AV*)sv_dup((SV*)s)
7421 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7422 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7423 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7424 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7425 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7426 #define io_dup(s) (IO*)sv_dup((SV*)s)
7427 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7428 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7429 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7430 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7431 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7434 Perl_re_dup(pTHX_ REGEXP *r)
7436 /* XXX fix when pmop->op_pmregexp becomes shared */
7437 return ReREFCNT_inc(r);
7441 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7445 return (PerlIO*)NULL;
7447 /* look for it in the table first */
7448 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7452 /* create anew and remember what it is */
7453 ret = PerlIO_fdupopen(aTHX_ fp);
7454 ptr_table_store(PL_ptr_table, fp, ret);
7459 Perl_dirp_dup(pTHX_ DIR *dp)
7468 Perl_gp_dup(pTHX_ GP *gp)
7473 /* look for it in the table first */
7474 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7478 /* create anew and remember what it is */
7479 Newz(0, ret, 1, GP);
7480 ptr_table_store(PL_ptr_table, gp, ret);
7483 ret->gp_refcnt = 0; /* must be before any other dups! */
7484 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7485 ret->gp_io = io_dup_inc(gp->gp_io);
7486 ret->gp_form = cv_dup_inc(gp->gp_form);
7487 ret->gp_av = av_dup_inc(gp->gp_av);
7488 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7489 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7490 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7491 ret->gp_cvgen = gp->gp_cvgen;
7492 ret->gp_flags = gp->gp_flags;
7493 ret->gp_line = gp->gp_line;
7494 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7499 Perl_mg_dup(pTHX_ MAGIC *mg)
7501 MAGIC *mgret = (MAGIC*)NULL;
7504 return (MAGIC*)NULL;
7505 /* look for it in the table first */
7506 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7510 for (; mg; mg = mg->mg_moremagic) {
7512 Newz(0, nmg, 1, MAGIC);
7516 mgprev->mg_moremagic = nmg;
7517 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7518 nmg->mg_private = mg->mg_private;
7519 nmg->mg_type = mg->mg_type;
7520 nmg->mg_flags = mg->mg_flags;
7521 if (mg->mg_type == 'r') {
7522 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7525 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7526 ? sv_dup_inc(mg->mg_obj)
7527 : sv_dup(mg->mg_obj);
7529 nmg->mg_len = mg->mg_len;
7530 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7531 if (mg->mg_ptr && mg->mg_type != 'g') {
7532 if (mg->mg_len >= 0) {
7533 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7534 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7535 AMT *amtp = (AMT*)mg->mg_ptr;
7536 AMT *namtp = (AMT*)nmg->mg_ptr;
7538 for (i = 1; i < NofAMmeth; i++) {
7539 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7543 else if (mg->mg_len == HEf_SVKEY)
7544 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7552 Perl_ptr_table_new(pTHX)
7555 Newz(0, tbl, 1, PTR_TBL_t);
7558 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7563 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7565 PTR_TBL_ENT_t *tblent;
7566 UV hash = PTR2UV(sv);
7568 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7569 for (; tblent; tblent = tblent->next) {
7570 if (tblent->oldval == sv)
7571 return tblent->newval;
7577 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7579 PTR_TBL_ENT_t *tblent, **otblent;
7580 /* XXX this may be pessimal on platforms where pointers aren't good
7581 * hash values e.g. if they grow faster in the most significant
7583 UV hash = PTR2UV(oldv);
7587 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7588 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7589 if (tblent->oldval == oldv) {
7590 tblent->newval = newv;
7595 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7596 tblent->oldval = oldv;
7597 tblent->newval = newv;
7598 tblent->next = *otblent;
7601 if (i && tbl->tbl_items > tbl->tbl_max)
7602 ptr_table_split(tbl);
7606 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7608 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7609 UV oldsize = tbl->tbl_max + 1;
7610 UV newsize = oldsize * 2;
7613 Renew(ary, newsize, PTR_TBL_ENT_t*);
7614 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7615 tbl->tbl_max = --newsize;
7617 for (i=0; i < oldsize; i++, ary++) {
7618 PTR_TBL_ENT_t **curentp, **entp, *ent;
7621 curentp = ary + oldsize;
7622 for (entp = ary, ent = *ary; ent; ent = *entp) {
7623 if ((newsize & PTR2UV(ent->oldval)) != i) {
7625 ent->next = *curentp;
7640 Perl_sv_dup(pTHX_ SV *sstr)
7644 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7646 /* look for it in the table first */
7647 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7651 /* create anew and remember what it is */
7653 ptr_table_store(PL_ptr_table, sstr, dstr);
7656 SvFLAGS(dstr) = SvFLAGS(sstr);
7657 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7658 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7661 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7662 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7663 PL_watch_pvx, SvPVX(sstr));
7666 switch (SvTYPE(sstr)) {
7671 SvANY(dstr) = new_XIV();
7672 SvIVX(dstr) = SvIVX(sstr);
7675 SvANY(dstr) = new_XNV();
7676 SvNVX(dstr) = SvNVX(sstr);
7679 SvANY(dstr) = new_XRV();
7680 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7683 SvANY(dstr) = new_XPV();
7684 SvCUR(dstr) = SvCUR(sstr);
7685 SvLEN(dstr) = SvLEN(sstr);
7687 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7688 else if (SvPVX(sstr) && SvLEN(sstr))
7689 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7691 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7694 SvANY(dstr) = new_XPVIV();
7695 SvCUR(dstr) = SvCUR(sstr);
7696 SvLEN(dstr) = SvLEN(sstr);
7697 SvIVX(dstr) = SvIVX(sstr);
7699 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7700 else if (SvPVX(sstr) && SvLEN(sstr))
7701 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7703 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7706 SvANY(dstr) = new_XPVNV();
7707 SvCUR(dstr) = SvCUR(sstr);
7708 SvLEN(dstr) = SvLEN(sstr);
7709 SvIVX(dstr) = SvIVX(sstr);
7710 SvNVX(dstr) = SvNVX(sstr);
7712 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7713 else if (SvPVX(sstr) && SvLEN(sstr))
7714 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7716 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7719 SvANY(dstr) = new_XPVMG();
7720 SvCUR(dstr) = SvCUR(sstr);
7721 SvLEN(dstr) = SvLEN(sstr);
7722 SvIVX(dstr) = SvIVX(sstr);
7723 SvNVX(dstr) = SvNVX(sstr);
7724 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7725 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7727 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7728 else if (SvPVX(sstr) && SvLEN(sstr))
7729 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7731 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7734 SvANY(dstr) = new_XPVBM();
7735 SvCUR(dstr) = SvCUR(sstr);
7736 SvLEN(dstr) = SvLEN(sstr);
7737 SvIVX(dstr) = SvIVX(sstr);
7738 SvNVX(dstr) = SvNVX(sstr);
7739 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7740 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7742 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7743 else if (SvPVX(sstr) && SvLEN(sstr))
7744 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7746 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7747 BmRARE(dstr) = BmRARE(sstr);
7748 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7749 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7752 SvANY(dstr) = new_XPVLV();
7753 SvCUR(dstr) = SvCUR(sstr);
7754 SvLEN(dstr) = SvLEN(sstr);
7755 SvIVX(dstr) = SvIVX(sstr);
7756 SvNVX(dstr) = SvNVX(sstr);
7757 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7758 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7760 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7761 else if (SvPVX(sstr) && SvLEN(sstr))
7762 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7764 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7765 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7766 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7767 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7768 LvTYPE(dstr) = LvTYPE(sstr);
7771 SvANY(dstr) = new_XPVGV();
7772 SvCUR(dstr) = SvCUR(sstr);
7773 SvLEN(dstr) = SvLEN(sstr);
7774 SvIVX(dstr) = SvIVX(sstr);
7775 SvNVX(dstr) = SvNVX(sstr);
7776 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7777 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7779 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7780 else if (SvPVX(sstr) && SvLEN(sstr))
7781 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7783 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7784 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7785 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7786 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7787 GvFLAGS(dstr) = GvFLAGS(sstr);
7788 GvGP(dstr) = gp_dup(GvGP(sstr));
7789 (void)GpREFCNT_inc(GvGP(dstr));
7792 SvANY(dstr) = new_XPVIO();
7793 SvCUR(dstr) = SvCUR(sstr);
7794 SvLEN(dstr) = SvLEN(sstr);
7795 SvIVX(dstr) = SvIVX(sstr);
7796 SvNVX(dstr) = SvNVX(sstr);
7797 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7798 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7800 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7801 else if (SvPVX(sstr) && SvLEN(sstr))
7802 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7804 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7805 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7806 if (IoOFP(sstr) == IoIFP(sstr))
7807 IoOFP(dstr) = IoIFP(dstr);
7809 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7810 /* PL_rsfp_filters entries have fake IoDIRP() */
7811 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7812 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7814 IoDIRP(dstr) = IoDIRP(sstr);
7815 IoLINES(dstr) = IoLINES(sstr);
7816 IoPAGE(dstr) = IoPAGE(sstr);
7817 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7818 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7819 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7820 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7821 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7822 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7823 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7824 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7825 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7826 IoTYPE(dstr) = IoTYPE(sstr);
7827 IoFLAGS(dstr) = IoFLAGS(sstr);
7830 SvANY(dstr) = new_XPVAV();
7831 SvCUR(dstr) = SvCUR(sstr);
7832 SvLEN(dstr) = SvLEN(sstr);
7833 SvIVX(dstr) = SvIVX(sstr);
7834 SvNVX(dstr) = SvNVX(sstr);
7835 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7836 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7837 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7838 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7839 if (AvARRAY((AV*)sstr)) {
7840 SV **dst_ary, **src_ary;
7841 SSize_t items = AvFILLp((AV*)sstr) + 1;
7843 src_ary = AvARRAY((AV*)sstr);
7844 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7845 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7846 SvPVX(dstr) = (char*)dst_ary;
7847 AvALLOC((AV*)dstr) = dst_ary;
7848 if (AvREAL((AV*)sstr)) {
7850 *dst_ary++ = sv_dup_inc(*src_ary++);
7854 *dst_ary++ = sv_dup(*src_ary++);
7856 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7857 while (items-- > 0) {
7858 *dst_ary++ = &PL_sv_undef;
7862 SvPVX(dstr) = Nullch;
7863 AvALLOC((AV*)dstr) = (SV**)NULL;
7867 SvANY(dstr) = new_XPVHV();
7868 SvCUR(dstr) = SvCUR(sstr);
7869 SvLEN(dstr) = SvLEN(sstr);
7870 SvIVX(dstr) = SvIVX(sstr);
7871 SvNVX(dstr) = SvNVX(sstr);
7872 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7873 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7874 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7875 if (HvARRAY((HV*)sstr)) {
7877 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7878 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7879 Newz(0, dxhv->xhv_array,
7880 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7881 while (i <= sxhv->xhv_max) {
7882 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7883 !!HvSHAREKEYS(sstr));
7886 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7889 SvPVX(dstr) = Nullch;
7890 HvEITER((HV*)dstr) = (HE*)NULL;
7892 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7893 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7896 SvANY(dstr) = new_XPVFM();
7897 FmLINES(dstr) = FmLINES(sstr);
7901 SvANY(dstr) = new_XPVCV();
7903 SvCUR(dstr) = SvCUR(sstr);
7904 SvLEN(dstr) = SvLEN(sstr);
7905 SvIVX(dstr) = SvIVX(sstr);
7906 SvNVX(dstr) = SvNVX(sstr);
7907 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7908 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7909 if (SvPVX(sstr) && SvLEN(sstr))
7910 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7912 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7913 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7914 CvSTART(dstr) = CvSTART(sstr);
7915 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7916 CvXSUB(dstr) = CvXSUB(sstr);
7917 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7918 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7919 CvDEPTH(dstr) = CvDEPTH(sstr);
7920 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7921 /* XXX padlists are real, but pretend to be not */
7922 AvREAL_on(CvPADLIST(sstr));
7923 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7924 AvREAL_off(CvPADLIST(sstr));
7925 AvREAL_off(CvPADLIST(dstr));
7928 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7929 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7930 CvFLAGS(dstr) = CvFLAGS(sstr);
7933 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7937 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7944 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7949 return (PERL_CONTEXT*)NULL;
7951 /* look for it in the table first */
7952 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7956 /* create anew and remember what it is */
7957 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7958 ptr_table_store(PL_ptr_table, cxs, ncxs);
7961 PERL_CONTEXT *cx = &cxs[ix];
7962 PERL_CONTEXT *ncx = &ncxs[ix];
7963 ncx->cx_type = cx->cx_type;
7964 if (CxTYPE(cx) == CXt_SUBST) {
7965 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7968 ncx->blk_oldsp = cx->blk_oldsp;
7969 ncx->blk_oldcop = cx->blk_oldcop;
7970 ncx->blk_oldretsp = cx->blk_oldretsp;
7971 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7972 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7973 ncx->blk_oldpm = cx->blk_oldpm;
7974 ncx->blk_gimme = cx->blk_gimme;
7975 switch (CxTYPE(cx)) {
7977 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7978 ? cv_dup_inc(cx->blk_sub.cv)
7979 : cv_dup(cx->blk_sub.cv));
7980 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
7981 ? av_dup_inc(cx->blk_sub.argarray)
7983 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
7984 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
7985 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
7986 ncx->blk_sub.lval = cx->blk_sub.lval;
7989 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
7990 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
7991 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
7992 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
7993 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
7996 ncx->blk_loop.label = cx->blk_loop.label;
7997 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
7998 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
7999 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8000 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8001 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8002 ? cx->blk_loop.iterdata
8003 : gv_dup((GV*)cx->blk_loop.iterdata));
8004 ncx->blk_loop.oldcurpad
8005 = (SV**)ptr_table_fetch(PL_ptr_table,
8006 cx->blk_loop.oldcurpad);
8007 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8008 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8009 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8010 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8011 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8014 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8015 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8016 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8017 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8030 Perl_si_dup(pTHX_ PERL_SI *si)
8035 return (PERL_SI*)NULL;
8037 /* look for it in the table first */
8038 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8042 /* create anew and remember what it is */
8043 Newz(56, nsi, 1, PERL_SI);
8044 ptr_table_store(PL_ptr_table, si, nsi);
8046 nsi->si_stack = av_dup_inc(si->si_stack);
8047 nsi->si_cxix = si->si_cxix;
8048 nsi->si_cxmax = si->si_cxmax;
8049 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8050 nsi->si_type = si->si_type;
8051 nsi->si_prev = si_dup(si->si_prev);
8052 nsi->si_next = si_dup(si->si_next);
8053 nsi->si_markoff = si->si_markoff;
8058 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8059 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8060 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8061 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8062 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8063 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8064 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8065 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8066 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8067 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8068 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8069 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8072 #define pv_dup_inc(p) SAVEPV(p)
8073 #define pv_dup(p) SAVEPV(p)
8074 #define svp_dup_inc(p,pp) any_dup(p,pp)
8077 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8084 /* look for it in the table first */
8085 ret = ptr_table_fetch(PL_ptr_table, v);
8089 /* see if it is part of the interpreter structure */
8090 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8091 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8099 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8101 ANY *ss = proto_perl->Tsavestack;
8102 I32 ix = proto_perl->Tsavestack_ix;
8103 I32 max = proto_perl->Tsavestack_max;
8116 void (*dptr) (void*);
8117 void (*dxptr) (pTHXo_ void*);
8120 Newz(54, nss, max, ANY);
8126 case SAVEt_ITEM: /* normal string */
8127 sv = (SV*)POPPTR(ss,ix);
8128 TOPPTR(nss,ix) = sv_dup_inc(sv);
8129 sv = (SV*)POPPTR(ss,ix);
8130 TOPPTR(nss,ix) = sv_dup_inc(sv);
8132 case SAVEt_SV: /* scalar reference */
8133 sv = (SV*)POPPTR(ss,ix);
8134 TOPPTR(nss,ix) = sv_dup_inc(sv);
8135 gv = (GV*)POPPTR(ss,ix);
8136 TOPPTR(nss,ix) = gv_dup_inc(gv);
8138 case SAVEt_GENERIC_PVREF: /* generic char* */
8139 c = (char*)POPPTR(ss,ix);
8140 TOPPTR(nss,ix) = pv_dup(c);
8141 ptr = POPPTR(ss,ix);
8142 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8144 case SAVEt_GENERIC_SVREF: /* generic sv */
8145 case SAVEt_SVREF: /* scalar reference */
8146 sv = (SV*)POPPTR(ss,ix);
8147 TOPPTR(nss,ix) = sv_dup_inc(sv);
8148 ptr = POPPTR(ss,ix);
8149 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8151 case SAVEt_AV: /* array reference */
8152 av = (AV*)POPPTR(ss,ix);
8153 TOPPTR(nss,ix) = av_dup_inc(av);
8154 gv = (GV*)POPPTR(ss,ix);
8155 TOPPTR(nss,ix) = gv_dup(gv);
8157 case SAVEt_HV: /* hash reference */
8158 hv = (HV*)POPPTR(ss,ix);
8159 TOPPTR(nss,ix) = hv_dup_inc(hv);
8160 gv = (GV*)POPPTR(ss,ix);
8161 TOPPTR(nss,ix) = gv_dup(gv);
8163 case SAVEt_INT: /* int reference */
8164 ptr = POPPTR(ss,ix);
8165 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8166 intval = (int)POPINT(ss,ix);
8167 TOPINT(nss,ix) = intval;
8169 case SAVEt_LONG: /* long reference */
8170 ptr = POPPTR(ss,ix);
8171 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8172 longval = (long)POPLONG(ss,ix);
8173 TOPLONG(nss,ix) = longval;
8175 case SAVEt_I32: /* I32 reference */
8176 case SAVEt_I16: /* I16 reference */
8177 case SAVEt_I8: /* I8 reference */
8178 ptr = POPPTR(ss,ix);
8179 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8183 case SAVEt_IV: /* IV reference */
8184 ptr = POPPTR(ss,ix);
8185 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8189 case SAVEt_SPTR: /* SV* reference */
8190 ptr = POPPTR(ss,ix);
8191 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8192 sv = (SV*)POPPTR(ss,ix);
8193 TOPPTR(nss,ix) = sv_dup(sv);
8195 case SAVEt_VPTR: /* random* reference */
8196 ptr = POPPTR(ss,ix);
8197 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8198 ptr = POPPTR(ss,ix);
8199 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8201 case SAVEt_PPTR: /* char* reference */
8202 ptr = POPPTR(ss,ix);
8203 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8204 c = (char*)POPPTR(ss,ix);
8205 TOPPTR(nss,ix) = pv_dup(c);
8207 case SAVEt_HPTR: /* HV* reference */
8208 ptr = POPPTR(ss,ix);
8209 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8210 hv = (HV*)POPPTR(ss,ix);
8211 TOPPTR(nss,ix) = hv_dup(hv);
8213 case SAVEt_APTR: /* AV* reference */
8214 ptr = POPPTR(ss,ix);
8215 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8216 av = (AV*)POPPTR(ss,ix);
8217 TOPPTR(nss,ix) = av_dup(av);
8220 gv = (GV*)POPPTR(ss,ix);
8221 TOPPTR(nss,ix) = gv_dup(gv);
8223 case SAVEt_GP: /* scalar reference */
8224 gp = (GP*)POPPTR(ss,ix);
8225 TOPPTR(nss,ix) = gp = gp_dup(gp);
8226 (void)GpREFCNT_inc(gp);
8227 gv = (GV*)POPPTR(ss,ix);
8228 TOPPTR(nss,ix) = gv_dup_inc(c);
8229 c = (char*)POPPTR(ss,ix);
8230 TOPPTR(nss,ix) = pv_dup(c);
8237 sv = (SV*)POPPTR(ss,ix);
8238 TOPPTR(nss,ix) = sv_dup_inc(sv);
8241 ptr = POPPTR(ss,ix);
8242 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8243 /* these are assumed to be refcounted properly */
8244 switch (((OP*)ptr)->op_type) {
8251 TOPPTR(nss,ix) = ptr;
8256 TOPPTR(nss,ix) = Nullop;
8261 TOPPTR(nss,ix) = Nullop;
8264 c = (char*)POPPTR(ss,ix);
8265 TOPPTR(nss,ix) = pv_dup_inc(c);
8268 longval = POPLONG(ss,ix);
8269 TOPLONG(nss,ix) = longval;
8272 hv = (HV*)POPPTR(ss,ix);
8273 TOPPTR(nss,ix) = hv_dup_inc(hv);
8274 c = (char*)POPPTR(ss,ix);
8275 TOPPTR(nss,ix) = pv_dup_inc(c);
8279 case SAVEt_DESTRUCTOR:
8280 ptr = POPPTR(ss,ix);
8281 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8282 dptr = POPDPTR(ss,ix);
8283 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8285 case SAVEt_DESTRUCTOR_X:
8286 ptr = POPPTR(ss,ix);
8287 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8288 dxptr = POPDXPTR(ss,ix);
8289 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8291 case SAVEt_REGCONTEXT:
8297 case SAVEt_STACK_POS: /* Position on Perl stack */
8301 case SAVEt_AELEM: /* array element */
8302 sv = (SV*)POPPTR(ss,ix);
8303 TOPPTR(nss,ix) = sv_dup_inc(sv);
8306 av = (AV*)POPPTR(ss,ix);
8307 TOPPTR(nss,ix) = av_dup_inc(av);
8309 case SAVEt_HELEM: /* hash element */
8310 sv = (SV*)POPPTR(ss,ix);
8311 TOPPTR(nss,ix) = sv_dup_inc(sv);
8312 sv = (SV*)POPPTR(ss,ix);
8313 TOPPTR(nss,ix) = sv_dup_inc(sv);
8314 hv = (HV*)POPPTR(ss,ix);
8315 TOPPTR(nss,ix) = hv_dup_inc(hv);
8318 ptr = POPPTR(ss,ix);
8319 TOPPTR(nss,ix) = ptr;
8326 av = (AV*)POPPTR(ss,ix);
8327 TOPPTR(nss,ix) = av_dup(av);
8330 longval = (long)POPLONG(ss,ix);
8331 TOPLONG(nss,ix) = longval;
8332 ptr = POPPTR(ss,ix);
8333 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8334 sv = (SV*)POPPTR(ss,ix);
8335 TOPPTR(nss,ix) = sv_dup(sv);
8338 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8350 perl_clone(PerlInterpreter *proto_perl, UV flags)
8353 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8356 #ifdef PERL_IMPLICIT_SYS
8357 return perl_clone_using(proto_perl, flags,
8359 proto_perl->IMemShared,
8360 proto_perl->IMemParse,
8370 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8371 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8372 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8373 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8374 struct IPerlDir* ipD, struct IPerlSock* ipS,
8375 struct IPerlProc* ipP)
8377 /* XXX many of the string copies here can be optimized if they're
8378 * constants; they need to be allocated as common memory and just
8379 * their pointers copied. */
8383 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8385 PERL_SET_THX(pPerl);
8386 # else /* !PERL_OBJECT */
8387 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8388 PERL_SET_THX(my_perl);
8391 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8396 # else /* !DEBUGGING */
8397 Zero(my_perl, 1, PerlInterpreter);
8398 # endif /* DEBUGGING */
8402 PL_MemShared = ipMS;
8410 # endif /* PERL_OBJECT */
8411 #else /* !PERL_IMPLICIT_SYS */
8413 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8414 PERL_SET_THX(my_perl);
8417 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8422 # else /* !DEBUGGING */
8423 Zero(my_perl, 1, PerlInterpreter);
8424 # endif /* DEBUGGING */
8425 #endif /* PERL_IMPLICIT_SYS */
8428 PL_xiv_arenaroot = NULL;
8430 PL_xnv_arenaroot = NULL;
8432 PL_xrv_arenaroot = NULL;
8434 PL_xpv_arenaroot = NULL;
8436 PL_xpviv_arenaroot = NULL;
8437 PL_xpviv_root = NULL;
8438 PL_xpvnv_arenaroot = NULL;
8439 PL_xpvnv_root = NULL;
8440 PL_xpvcv_arenaroot = NULL;
8441 PL_xpvcv_root = NULL;
8442 PL_xpvav_arenaroot = NULL;
8443 PL_xpvav_root = NULL;
8444 PL_xpvhv_arenaroot = NULL;
8445 PL_xpvhv_root = NULL;
8446 PL_xpvmg_arenaroot = NULL;
8447 PL_xpvmg_root = NULL;
8448 PL_xpvlv_arenaroot = NULL;
8449 PL_xpvlv_root = NULL;
8450 PL_xpvbm_arenaroot = NULL;
8451 PL_xpvbm_root = NULL;
8452 PL_he_arenaroot = NULL;
8454 PL_nice_chunk = NULL;
8455 PL_nice_chunk_size = 0;
8458 PL_sv_root = Nullsv;
8459 PL_sv_arenaroot = Nullsv;
8461 PL_debug = proto_perl->Idebug;
8463 /* create SV map for pointer relocation */
8464 PL_ptr_table = ptr_table_new();
8466 /* initialize these special pointers as early as possible */
8467 SvANY(&PL_sv_undef) = NULL;
8468 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8469 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8470 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8473 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8475 SvANY(&PL_sv_no) = new_XPVNV();
8477 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8478 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8479 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8480 SvCUR(&PL_sv_no) = 0;
8481 SvLEN(&PL_sv_no) = 1;
8482 SvNVX(&PL_sv_no) = 0;
8483 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8486 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8488 SvANY(&PL_sv_yes) = new_XPVNV();
8490 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8491 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8492 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8493 SvCUR(&PL_sv_yes) = 1;
8494 SvLEN(&PL_sv_yes) = 2;
8495 SvNVX(&PL_sv_yes) = 1;
8496 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8498 /* create shared string table */
8499 PL_strtab = newHV();
8500 HvSHAREKEYS_off(PL_strtab);
8501 hv_ksplit(PL_strtab, 512);
8502 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8504 PL_compiling = proto_perl->Icompiling;
8505 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8506 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8507 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8508 if (!specialWARN(PL_compiling.cop_warnings))
8509 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8510 if (!specialCopIO(PL_compiling.cop_io))
8511 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8512 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8514 /* pseudo environmental stuff */
8515 PL_origargc = proto_perl->Iorigargc;
8517 New(0, PL_origargv, i+1, char*);
8518 PL_origargv[i] = '\0';
8520 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8522 PL_envgv = gv_dup(proto_perl->Ienvgv);
8523 PL_incgv = gv_dup(proto_perl->Iincgv);
8524 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8525 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8526 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8527 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8530 PL_minus_c = proto_perl->Iminus_c;
8531 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8532 PL_localpatches = proto_perl->Ilocalpatches;
8533 PL_splitstr = proto_perl->Isplitstr;
8534 PL_preprocess = proto_perl->Ipreprocess;
8535 PL_minus_n = proto_perl->Iminus_n;
8536 PL_minus_p = proto_perl->Iminus_p;
8537 PL_minus_l = proto_perl->Iminus_l;
8538 PL_minus_a = proto_perl->Iminus_a;
8539 PL_minus_F = proto_perl->Iminus_F;
8540 PL_doswitches = proto_perl->Idoswitches;
8541 PL_dowarn = proto_perl->Idowarn;
8542 PL_doextract = proto_perl->Idoextract;
8543 PL_sawampersand = proto_perl->Isawampersand;
8544 PL_unsafe = proto_perl->Iunsafe;
8545 PL_inplace = SAVEPV(proto_perl->Iinplace);
8546 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8547 PL_perldb = proto_perl->Iperldb;
8548 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8550 /* magical thingies */
8551 /* XXX time(&PL_basetime) when asked for? */
8552 PL_basetime = proto_perl->Ibasetime;
8553 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8555 PL_maxsysfd = proto_perl->Imaxsysfd;
8556 PL_multiline = proto_perl->Imultiline;
8557 PL_statusvalue = proto_perl->Istatusvalue;
8559 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8562 /* shortcuts to various I/O objects */
8563 PL_stdingv = gv_dup(proto_perl->Istdingv);
8564 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8565 PL_defgv = gv_dup(proto_perl->Idefgv);
8566 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8567 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8568 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8570 /* shortcuts to regexp stuff */
8571 PL_replgv = gv_dup(proto_perl->Ireplgv);
8573 /* shortcuts to misc objects */
8574 PL_errgv = gv_dup(proto_perl->Ierrgv);
8576 /* shortcuts to debugging objects */
8577 PL_DBgv = gv_dup(proto_perl->IDBgv);
8578 PL_DBline = gv_dup(proto_perl->IDBline);
8579 PL_DBsub = gv_dup(proto_perl->IDBsub);
8580 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8581 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8582 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8583 PL_lineary = av_dup(proto_perl->Ilineary);
8584 PL_dbargs = av_dup(proto_perl->Idbargs);
8587 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8588 PL_curstash = hv_dup(proto_perl->Tcurstash);
8589 PL_debstash = hv_dup(proto_perl->Idebstash);
8590 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8591 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8593 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8594 PL_endav = av_dup_inc(proto_perl->Iendav);
8595 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8596 PL_initav = av_dup_inc(proto_perl->Iinitav);
8598 PL_sub_generation = proto_perl->Isub_generation;
8600 /* funky return mechanisms */
8601 PL_forkprocess = proto_perl->Iforkprocess;
8603 /* subprocess state */
8604 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8606 /* internal state */
8607 PL_tainting = proto_perl->Itainting;
8608 PL_maxo = proto_perl->Imaxo;
8609 if (proto_perl->Iop_mask)
8610 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8612 PL_op_mask = Nullch;
8614 /* current interpreter roots */
8615 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8616 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8617 PL_main_start = proto_perl->Imain_start;
8618 PL_eval_root = proto_perl->Ieval_root;
8619 PL_eval_start = proto_perl->Ieval_start;
8621 /* runtime control stuff */
8622 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8623 PL_copline = proto_perl->Icopline;
8625 PL_filemode = proto_perl->Ifilemode;
8626 PL_lastfd = proto_perl->Ilastfd;
8627 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8630 PL_gensym = proto_perl->Igensym;
8631 PL_preambled = proto_perl->Ipreambled;
8632 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8633 PL_laststatval = proto_perl->Ilaststatval;
8634 PL_laststype = proto_perl->Ilaststype;
8635 PL_mess_sv = Nullsv;
8637 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8638 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8640 /* interpreter atexit processing */
8641 PL_exitlistlen = proto_perl->Iexitlistlen;
8642 if (PL_exitlistlen) {
8643 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8644 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8647 PL_exitlist = (PerlExitListEntry*)NULL;
8648 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8650 PL_profiledata = NULL;
8651 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8652 /* PL_rsfp_filters entries have fake IoDIRP() */
8653 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8655 PL_compcv = cv_dup(proto_perl->Icompcv);
8656 PL_comppad = av_dup(proto_perl->Icomppad);
8657 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8658 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8659 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8660 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8661 proto_perl->Tcurpad);
8663 #ifdef HAVE_INTERP_INTERN
8664 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8667 /* more statics moved here */
8668 PL_generation = proto_perl->Igeneration;
8669 PL_DBcv = cv_dup(proto_perl->IDBcv);
8671 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8672 PL_in_clean_all = proto_perl->Iin_clean_all;
8674 PL_uid = proto_perl->Iuid;
8675 PL_euid = proto_perl->Ieuid;
8676 PL_gid = proto_perl->Igid;
8677 PL_egid = proto_perl->Iegid;
8678 PL_nomemok = proto_perl->Inomemok;
8679 PL_an = proto_perl->Ian;
8680 PL_cop_seqmax = proto_perl->Icop_seqmax;
8681 PL_op_seqmax = proto_perl->Iop_seqmax;
8682 PL_evalseq = proto_perl->Ievalseq;
8683 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8684 PL_origalen = proto_perl->Iorigalen;
8685 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8686 PL_osname = SAVEPV(proto_perl->Iosname);
8687 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8688 PL_sighandlerp = proto_perl->Isighandlerp;
8691 PL_runops = proto_perl->Irunops;
8693 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8696 PL_cshlen = proto_perl->Icshlen;
8697 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8700 PL_lex_state = proto_perl->Ilex_state;
8701 PL_lex_defer = proto_perl->Ilex_defer;
8702 PL_lex_expect = proto_perl->Ilex_expect;
8703 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8704 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8705 PL_lex_starts = proto_perl->Ilex_starts;
8706 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8707 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8708 PL_lex_op = proto_perl->Ilex_op;
8709 PL_lex_inpat = proto_perl->Ilex_inpat;
8710 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8711 PL_lex_brackets = proto_perl->Ilex_brackets;
8712 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8713 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8714 PL_lex_casemods = proto_perl->Ilex_casemods;
8715 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8716 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8718 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8719 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8720 PL_nexttoke = proto_perl->Inexttoke;
8722 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8723 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8724 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8725 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8726 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8727 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8728 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8729 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8730 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8731 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8732 PL_pending_ident = proto_perl->Ipending_ident;
8733 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8735 PL_expect = proto_perl->Iexpect;
8737 PL_multi_start = proto_perl->Imulti_start;
8738 PL_multi_end = proto_perl->Imulti_end;
8739 PL_multi_open = proto_perl->Imulti_open;
8740 PL_multi_close = proto_perl->Imulti_close;
8742 PL_error_count = proto_perl->Ierror_count;
8743 PL_subline = proto_perl->Isubline;
8744 PL_subname = sv_dup_inc(proto_perl->Isubname);
8746 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8747 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8748 PL_padix = proto_perl->Ipadix;
8749 PL_padix_floor = proto_perl->Ipadix_floor;
8750 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8752 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8753 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8754 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8755 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8756 PL_last_lop_op = proto_perl->Ilast_lop_op;
8757 PL_in_my = proto_perl->Iin_my;
8758 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8760 PL_cryptseen = proto_perl->Icryptseen;
8763 PL_hints = proto_perl->Ihints;
8765 PL_amagic_generation = proto_perl->Iamagic_generation;
8767 #ifdef USE_LOCALE_COLLATE
8768 PL_collation_ix = proto_perl->Icollation_ix;
8769 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8770 PL_collation_standard = proto_perl->Icollation_standard;
8771 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8772 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8773 #endif /* USE_LOCALE_COLLATE */
8775 #ifdef USE_LOCALE_NUMERIC
8776 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8777 PL_numeric_standard = proto_perl->Inumeric_standard;
8778 PL_numeric_local = proto_perl->Inumeric_local;
8779 PL_numeric_radix = proto_perl->Inumeric_radix;
8780 #endif /* !USE_LOCALE_NUMERIC */
8782 /* utf8 character classes */
8783 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8784 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8785 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8786 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8787 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8788 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8789 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8790 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8791 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8792 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8793 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8794 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8795 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8796 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8797 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8798 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8799 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8802 PL_last_swash_hv = Nullhv; /* reinits on demand */
8803 PL_last_swash_klen = 0;
8804 PL_last_swash_key[0]= '\0';
8805 PL_last_swash_tmps = (U8*)NULL;
8806 PL_last_swash_slen = 0;
8808 /* perly.c globals */
8809 PL_yydebug = proto_perl->Iyydebug;
8810 PL_yynerrs = proto_perl->Iyynerrs;
8811 PL_yyerrflag = proto_perl->Iyyerrflag;
8812 PL_yychar = proto_perl->Iyychar;
8813 PL_yyval = proto_perl->Iyyval;
8814 PL_yylval = proto_perl->Iyylval;
8816 PL_glob_index = proto_perl->Iglob_index;
8817 PL_srand_called = proto_perl->Isrand_called;
8818 PL_uudmap['M'] = 0; /* reinits on demand */
8819 PL_bitcount = Nullch; /* reinits on demand */
8821 if (proto_perl->Ipsig_ptr) {
8822 int sig_num[] = { SIG_NUM };
8823 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8824 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8825 for (i = 1; PL_sig_name[i]; i++) {
8826 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8827 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8831 PL_psig_ptr = (SV**)NULL;
8832 PL_psig_name = (SV**)NULL;
8835 /* thrdvar.h stuff */
8838 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8839 PL_tmps_ix = proto_perl->Ttmps_ix;
8840 PL_tmps_max = proto_perl->Ttmps_max;
8841 PL_tmps_floor = proto_perl->Ttmps_floor;
8842 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8844 while (i <= PL_tmps_ix) {
8845 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8849 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8850 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8851 Newz(54, PL_markstack, i, I32);
8852 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8853 - proto_perl->Tmarkstack);
8854 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8855 - proto_perl->Tmarkstack);
8856 Copy(proto_perl->Tmarkstack, PL_markstack,
8857 PL_markstack_ptr - PL_markstack + 1, I32);
8859 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8860 * NOTE: unlike the others! */
8861 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8862 PL_scopestack_max = proto_perl->Tscopestack_max;
8863 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8864 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8866 /* next push_return() sets PL_retstack[PL_retstack_ix]
8867 * NOTE: unlike the others! */
8868 PL_retstack_ix = proto_perl->Tretstack_ix;
8869 PL_retstack_max = proto_perl->Tretstack_max;
8870 Newz(54, PL_retstack, PL_retstack_max, OP*);
8871 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8873 /* NOTE: si_dup() looks at PL_markstack */
8874 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8876 /* PL_curstack = PL_curstackinfo->si_stack; */
8877 PL_curstack = av_dup(proto_perl->Tcurstack);
8878 PL_mainstack = av_dup(proto_perl->Tmainstack);
8880 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8881 PL_stack_base = AvARRAY(PL_curstack);
8882 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8883 - proto_perl->Tstack_base);
8884 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8886 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8887 * NOTE: unlike the others! */
8888 PL_savestack_ix = proto_perl->Tsavestack_ix;
8889 PL_savestack_max = proto_perl->Tsavestack_max;
8890 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8891 PL_savestack = ss_dup(proto_perl);
8895 ENTER; /* perl_destruct() wants to LEAVE; */
8898 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8899 PL_top_env = &PL_start_env;
8901 PL_op = proto_perl->Top;
8904 PL_Xpv = (XPV*)NULL;
8905 PL_na = proto_perl->Tna;
8907 PL_statbuf = proto_perl->Tstatbuf;
8908 PL_statcache = proto_perl->Tstatcache;
8909 PL_statgv = gv_dup(proto_perl->Tstatgv);
8910 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8912 PL_timesbuf = proto_perl->Ttimesbuf;
8915 PL_tainted = proto_perl->Ttainted;
8916 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8917 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8918 PL_rs = sv_dup_inc(proto_perl->Trs);
8919 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8920 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
8921 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8922 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8923 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8924 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8925 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8927 PL_restartop = proto_perl->Trestartop;
8928 PL_in_eval = proto_perl->Tin_eval;
8929 PL_delaymagic = proto_perl->Tdelaymagic;
8930 PL_dirty = proto_perl->Tdirty;
8931 PL_localizing = proto_perl->Tlocalizing;
8933 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8934 PL_protect = proto_perl->Tprotect;
8936 PL_errors = sv_dup_inc(proto_perl->Terrors);
8937 PL_av_fetch_sv = Nullsv;
8938 PL_hv_fetch_sv = Nullsv;
8939 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8940 PL_modcount = proto_perl->Tmodcount;
8941 PL_lastgotoprobe = Nullop;
8942 PL_dumpindent = proto_perl->Tdumpindent;
8944 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8945 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8946 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8947 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8948 PL_sortcxix = proto_perl->Tsortcxix;
8949 PL_efloatbuf = Nullch; /* reinits on demand */
8950 PL_efloatsize = 0; /* reinits on demand */
8954 PL_screamfirst = NULL;
8955 PL_screamnext = NULL;
8956 PL_maxscream = -1; /* reinits on demand */
8957 PL_lastscream = Nullsv;
8959 PL_watchaddr = NULL;
8960 PL_watchok = Nullch;
8962 PL_regdummy = proto_perl->Tregdummy;
8963 PL_regcomp_parse = Nullch;
8964 PL_regxend = Nullch;
8965 PL_regcode = (regnode*)NULL;
8968 PL_regprecomp = Nullch;
8973 PL_seen_zerolen = 0;
8975 PL_regcomp_rx = (regexp*)NULL;
8977 PL_colorset = 0; /* reinits PL_colors[] */
8978 /*PL_colors[6] = {0,0,0,0,0,0};*/
8979 PL_reg_whilem_seen = 0;
8980 PL_reginput = Nullch;
8983 PL_regstartp = (I32*)NULL;
8984 PL_regendp = (I32*)NULL;
8985 PL_reglastparen = (U32*)NULL;
8986 PL_regtill = Nullch;
8988 PL_reg_start_tmp = (char**)NULL;
8989 PL_reg_start_tmpl = 0;
8990 PL_regdata = (struct reg_data*)NULL;
8993 PL_reg_eval_set = 0;
8995 PL_regprogram = (regnode*)NULL;
8997 PL_regcc = (CURCUR*)NULL;
8998 PL_reg_call_cc = (struct re_cc_state*)NULL;
8999 PL_reg_re = (regexp*)NULL;
9000 PL_reg_ganch = Nullch;
9002 PL_reg_magic = (MAGIC*)NULL;
9004 PL_reg_oldcurpm = (PMOP*)NULL;
9005 PL_reg_curpm = (PMOP*)NULL;
9006 PL_reg_oldsaved = Nullch;
9007 PL_reg_oldsavedlen = 0;
9009 PL_reg_leftiter = 0;
9010 PL_reg_poscache = Nullch;
9011 PL_reg_poscache_size= 0;
9013 /* RE engine - function pointers */
9014 PL_regcompp = proto_perl->Tregcompp;
9015 PL_regexecp = proto_perl->Tregexecp;
9016 PL_regint_start = proto_perl->Tregint_start;
9017 PL_regint_string = proto_perl->Tregint_string;
9018 PL_regfree = proto_perl->Tregfree;
9020 PL_reginterp_cnt = 0;
9021 PL_reg_starttry = 0;
9024 return (PerlInterpreter*)pPerl;
9030 #else /* !USE_ITHREADS */
9036 #endif /* USE_ITHREADS */
9039 do_report_used(pTHXo_ SV *sv)
9041 if (SvTYPE(sv) != SVTYPEMASK) {
9042 PerlIO_printf(Perl_debug_log, "****\n");
9048 do_clean_objs(pTHXo_ SV *sv)
9052 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9053 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9054 if (SvWEAKREF(sv)) {
9065 /* XXX Might want to check arrays, etc. */
9068 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9070 do_clean_named_objs(pTHXo_ SV *sv)
9072 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9073 if ( SvOBJECT(GvSV(sv)) ||
9074 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9075 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9076 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9077 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9079 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9087 do_clean_all(pTHXo_ SV *sv)
9089 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9090 SvFLAGS(sv) |= SVf_BREAK;