3 * Copyright (c) 1991-2000, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
29 * "A time to plant, and a time to uproot what was planted..."
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
40 /* sv_mutex must be held while calling uproot_SV() */
41 #define uproot_SV(p) \
44 PL_sv_root = (SV*)SvANY(p); \
66 if (PL_debug & 32768) \
76 if (PL_debug & 32768) {
81 for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) {
83 svend = &sva[SvREFCNT(sva)];
84 if (p >= sv && p < svend)
88 if (ckWARN_d(WARN_INTERNAL))
89 Perl_warner(aTHX_ WARN_INTERNAL,
90 "Attempt to free non-arena SV: 0x%"UVxf,
98 #else /* ! DEBUGGING */
100 #define del_SV(p) plant_SV(p)
102 #endif /* DEBUGGING */
105 Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags)
110 Zero(ptr, size, char);
112 /* The first SV in an arena isn't an SV. */
113 SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */
114 SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */
115 SvFLAGS(sva) = flags; /* FAKE if not to be freed */
117 PL_sv_arenaroot = sva;
118 PL_sv_root = sva + 1;
120 svend = &sva[SvREFCNT(sva) - 1];
123 SvANY(sv) = (void *)(SV*)(sv + 1);
124 SvFLAGS(sv) = SVTYPEMASK;
128 SvFLAGS(sv) = SVTYPEMASK;
131 /* sv_mutex must be held while calling more_sv() */
138 sv_add_arena(PL_nice_chunk, PL_nice_chunk_size, 0);
139 PL_nice_chunk = Nullch;
142 char *chunk; /* must use New here to match call to */
143 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
144 sv_add_arena(chunk, 1008, 0);
151 S_visit(pTHX_ SVFUNC_t f)
157 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
158 svend = &sva[SvREFCNT(sva)];
159 for (sv = sva + 1; sv < svend; ++sv) {
160 if (SvTYPE(sv) != SVTYPEMASK)
167 Perl_sv_report_used(pTHX)
169 visit(do_report_used);
173 Perl_sv_clean_objs(pTHX)
175 PL_in_clean_objs = TRUE;
176 visit(do_clean_objs);
177 #ifndef DISABLE_DESTRUCTOR_KLUDGE
178 /* some barnacles may yet remain, clinging to typeglobs */
179 visit(do_clean_named_objs);
181 PL_in_clean_objs = FALSE;
185 Perl_sv_clean_all(pTHX)
187 PL_in_clean_all = TRUE;
189 PL_in_clean_all = FALSE;
193 Perl_sv_free_arenas(pTHX)
197 XPV *arena, *arenanext;
199 /* Free arenas here, but be careful about fake ones. (We assume
200 contiguity of the fake ones with the corresponding real ones.) */
202 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
203 svanext = (SV*) SvANY(sva);
204 while (svanext && SvFAKE(svanext))
205 svanext = (SV*) SvANY(svanext);
208 Safefree((void *)sva);
211 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
212 arenanext = (XPV*)arena->xpv_pv;
215 PL_xiv_arenaroot = 0;
217 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
218 arenanext = (XPV*)arena->xpv_pv;
221 PL_xnv_arenaroot = 0;
223 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
224 arenanext = (XPV*)arena->xpv_pv;
227 PL_xrv_arenaroot = 0;
229 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
230 arenanext = (XPV*)arena->xpv_pv;
233 PL_xpv_arenaroot = 0;
235 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
236 arenanext = (XPV*)arena->xpv_pv;
239 PL_xpviv_arenaroot = 0;
241 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
242 arenanext = (XPV*)arena->xpv_pv;
245 PL_xpvnv_arenaroot = 0;
247 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
248 arenanext = (XPV*)arena->xpv_pv;
251 PL_xpvcv_arenaroot = 0;
253 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
254 arenanext = (XPV*)arena->xpv_pv;
257 PL_xpvav_arenaroot = 0;
259 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
260 arenanext = (XPV*)arena->xpv_pv;
263 PL_xpvhv_arenaroot = 0;
265 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
266 arenanext = (XPV*)arena->xpv_pv;
269 PL_xpvmg_arenaroot = 0;
271 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
272 arenanext = (XPV*)arena->xpv_pv;
275 PL_xpvlv_arenaroot = 0;
277 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
278 arenanext = (XPV*)arena->xpv_pv;
281 PL_xpvbm_arenaroot = 0;
283 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
284 arenanext = (XPV*)arena->xpv_pv;
290 Safefree(PL_nice_chunk);
291 PL_nice_chunk = Nullch;
292 PL_nice_chunk_size = 0;
298 Perl_report_uninit(pTHX)
301 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
302 " in ", PL_op_desc[PL_op->op_type]);
304 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
316 * See comment in more_xiv() -- RAM.
318 PL_xiv_root = *(IV**)xiv;
320 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
324 S_del_xiv(pTHX_ XPVIV *p)
326 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
328 *(IV**)xiv = PL_xiv_root;
339 New(705, ptr, 1008/sizeof(XPV), XPV);
340 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
341 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
344 xivend = &xiv[1008 / sizeof(IV) - 1];
345 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
347 while (xiv < xivend) {
348 *(IV**)xiv = (IV *)(xiv + 1);
362 PL_xnv_root = *(NV**)xnv;
364 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
368 S_del_xnv(pTHX_ XPVNV *p)
370 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
372 *(NV**)xnv = PL_xnv_root;
383 New(711, ptr, 1008/sizeof(XPV), XPV);
384 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
385 PL_xnv_arenaroot = ptr;
388 xnvend = &xnv[1008 / sizeof(NV) - 1];
389 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
391 while (xnv < xnvend) {
392 *(NV**)xnv = (NV*)(xnv + 1);
406 PL_xrv_root = (XRV*)xrv->xrv_rv;
412 S_del_xrv(pTHX_ XRV *p)
415 p->xrv_rv = (SV*)PL_xrv_root;
424 register XRV* xrvend;
426 New(712, ptr, 1008/sizeof(XPV), XPV);
427 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
428 PL_xrv_arenaroot = ptr;
431 xrvend = &xrv[1008 / sizeof(XRV) - 1];
432 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
434 while (xrv < xrvend) {
435 xrv->xrv_rv = (SV*)(xrv + 1);
449 PL_xpv_root = (XPV*)xpv->xpv_pv;
455 S_del_xpv(pTHX_ XPV *p)
458 p->xpv_pv = (char*)PL_xpv_root;
467 register XPV* xpvend;
468 New(713, xpv, 1008/sizeof(XPV), XPV);
469 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
470 PL_xpv_arenaroot = xpv;
472 xpvend = &xpv[1008 / sizeof(XPV) - 1];
474 while (xpv < xpvend) {
475 xpv->xpv_pv = (char*)(xpv + 1);
488 xpviv = PL_xpviv_root;
489 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
495 S_del_xpviv(pTHX_ XPVIV *p)
498 p->xpv_pv = (char*)PL_xpviv_root;
506 register XPVIV* xpviv;
507 register XPVIV* xpvivend;
508 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
509 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
510 PL_xpviv_arenaroot = xpviv;
512 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
513 PL_xpviv_root = ++xpviv;
514 while (xpviv < xpvivend) {
515 xpviv->xpv_pv = (char*)(xpviv + 1);
528 xpvnv = PL_xpvnv_root;
529 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
535 S_del_xpvnv(pTHX_ XPVNV *p)
538 p->xpv_pv = (char*)PL_xpvnv_root;
546 register XPVNV* xpvnv;
547 register XPVNV* xpvnvend;
548 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
549 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
550 PL_xpvnv_arenaroot = xpvnv;
552 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
553 PL_xpvnv_root = ++xpvnv;
554 while (xpvnv < xpvnvend) {
555 xpvnv->xpv_pv = (char*)(xpvnv + 1);
568 xpvcv = PL_xpvcv_root;
569 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
575 S_del_xpvcv(pTHX_ XPVCV *p)
578 p->xpv_pv = (char*)PL_xpvcv_root;
586 register XPVCV* xpvcv;
587 register XPVCV* xpvcvend;
588 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
589 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
590 PL_xpvcv_arenaroot = xpvcv;
592 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
593 PL_xpvcv_root = ++xpvcv;
594 while (xpvcv < xpvcvend) {
595 xpvcv->xpv_pv = (char*)(xpvcv + 1);
608 xpvav = PL_xpvav_root;
609 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
615 S_del_xpvav(pTHX_ XPVAV *p)
618 p->xav_array = (char*)PL_xpvav_root;
626 register XPVAV* xpvav;
627 register XPVAV* xpvavend;
628 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
629 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
630 PL_xpvav_arenaroot = xpvav;
632 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
633 PL_xpvav_root = ++xpvav;
634 while (xpvav < xpvavend) {
635 xpvav->xav_array = (char*)(xpvav + 1);
638 xpvav->xav_array = 0;
648 xpvhv = PL_xpvhv_root;
649 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
655 S_del_xpvhv(pTHX_ XPVHV *p)
658 p->xhv_array = (char*)PL_xpvhv_root;
666 register XPVHV* xpvhv;
667 register XPVHV* xpvhvend;
668 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
669 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
670 PL_xpvhv_arenaroot = xpvhv;
672 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
673 PL_xpvhv_root = ++xpvhv;
674 while (xpvhv < xpvhvend) {
675 xpvhv->xhv_array = (char*)(xpvhv + 1);
678 xpvhv->xhv_array = 0;
688 xpvmg = PL_xpvmg_root;
689 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
695 S_del_xpvmg(pTHX_ XPVMG *p)
698 p->xpv_pv = (char*)PL_xpvmg_root;
706 register XPVMG* xpvmg;
707 register XPVMG* xpvmgend;
708 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
709 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
710 PL_xpvmg_arenaroot = xpvmg;
712 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
713 PL_xpvmg_root = ++xpvmg;
714 while (xpvmg < xpvmgend) {
715 xpvmg->xpv_pv = (char*)(xpvmg + 1);
728 xpvlv = PL_xpvlv_root;
729 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
735 S_del_xpvlv(pTHX_ XPVLV *p)
738 p->xpv_pv = (char*)PL_xpvlv_root;
746 register XPVLV* xpvlv;
747 register XPVLV* xpvlvend;
748 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
749 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
750 PL_xpvlv_arenaroot = xpvlv;
752 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
753 PL_xpvlv_root = ++xpvlv;
754 while (xpvlv < xpvlvend) {
755 xpvlv->xpv_pv = (char*)(xpvlv + 1);
768 xpvbm = PL_xpvbm_root;
769 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
775 S_del_xpvbm(pTHX_ XPVBM *p)
778 p->xpv_pv = (char*)PL_xpvbm_root;
786 register XPVBM* xpvbm;
787 register XPVBM* xpvbmend;
788 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
789 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
790 PL_xpvbm_arenaroot = xpvbm;
792 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
793 PL_xpvbm_root = ++xpvbm;
794 while (xpvbm < xpvbmend) {
795 xpvbm->xpv_pv = (char*)(xpvbm + 1);
802 # define my_safemalloc(s) (void*)safexmalloc(717,s)
803 # define my_safefree(p) safexfree((char*)p)
805 # define my_safemalloc(s) (void*)safemalloc(s)
806 # define my_safefree(p) safefree((char*)p)
811 #define new_XIV() my_safemalloc(sizeof(XPVIV))
812 #define del_XIV(p) my_safefree(p)
814 #define new_XNV() my_safemalloc(sizeof(XPVNV))
815 #define del_XNV(p) my_safefree(p)
817 #define new_XRV() my_safemalloc(sizeof(XRV))
818 #define del_XRV(p) my_safefree(p)
820 #define new_XPV() my_safemalloc(sizeof(XPV))
821 #define del_XPV(p) my_safefree(p)
823 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
824 #define del_XPVIV(p) my_safefree(p)
826 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
827 #define del_XPVNV(p) my_safefree(p)
829 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
830 #define del_XPVCV(p) my_safefree(p)
832 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
833 #define del_XPVAV(p) my_safefree(p)
835 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
836 #define del_XPVHV(p) my_safefree(p)
838 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
839 #define del_XPVMG(p) my_safefree(p)
841 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
842 #define del_XPVLV(p) my_safefree(p)
844 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
845 #define del_XPVBM(p) my_safefree(p)
849 #define new_XIV() (void*)new_xiv()
850 #define del_XIV(p) del_xiv((XPVIV*) p)
852 #define new_XNV() (void*)new_xnv()
853 #define del_XNV(p) del_xnv((XPVNV*) p)
855 #define new_XRV() (void*)new_xrv()
856 #define del_XRV(p) del_xrv((XRV*) p)
858 #define new_XPV() (void*)new_xpv()
859 #define del_XPV(p) del_xpv((XPV *)p)
861 #define new_XPVIV() (void*)new_xpviv()
862 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
864 #define new_XPVNV() (void*)new_xpvnv()
865 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
867 #define new_XPVCV() (void*)new_xpvcv()
868 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
870 #define new_XPVAV() (void*)new_xpvav()
871 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
873 #define new_XPVHV() (void*)new_xpvhv()
874 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
876 #define new_XPVMG() (void*)new_xpvmg()
877 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
879 #define new_XPVLV() (void*)new_xpvlv()
880 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
882 #define new_XPVBM() (void*)new_xpvbm()
883 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
887 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
888 #define del_XPVGV(p) my_safefree(p)
890 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
891 #define del_XPVFM(p) my_safefree(p)
893 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
894 #define del_XPVIO(p) my_safefree(p)
897 =for apidoc sv_upgrade
899 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
906 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
916 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
920 if (SvTYPE(sv) == mt)
926 switch (SvTYPE(sv)) {
947 else if (mt < SVt_PVIV)
964 pv = (char*)SvRV(sv);
984 else if (mt == SVt_NV)
995 del_XPVIV(SvANY(sv));
1005 del_XPVNV(SvANY(sv));
1013 magic = SvMAGIC(sv);
1014 stash = SvSTASH(sv);
1015 del_XPVMG(SvANY(sv));
1018 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1023 Perl_croak(aTHX_ "Can't upgrade to undef");
1025 SvANY(sv) = new_XIV();
1029 SvANY(sv) = new_XNV();
1033 SvANY(sv) = new_XRV();
1037 SvANY(sv) = new_XPV();
1043 SvANY(sv) = new_XPVIV();
1053 SvANY(sv) = new_XPVNV();
1061 SvANY(sv) = new_XPVMG();
1067 SvMAGIC(sv) = magic;
1068 SvSTASH(sv) = stash;
1071 SvANY(sv) = new_XPVLV();
1077 SvMAGIC(sv) = magic;
1078 SvSTASH(sv) = stash;
1085 SvANY(sv) = new_XPVAV();
1093 SvMAGIC(sv) = magic;
1094 SvSTASH(sv) = stash;
1100 SvANY(sv) = new_XPVHV();
1108 SvMAGIC(sv) = magic;
1109 SvSTASH(sv) = stash;
1116 SvANY(sv) = new_XPVCV();
1117 Zero(SvANY(sv), 1, XPVCV);
1123 SvMAGIC(sv) = magic;
1124 SvSTASH(sv) = stash;
1127 SvANY(sv) = new_XPVGV();
1133 SvMAGIC(sv) = magic;
1134 SvSTASH(sv) = stash;
1142 SvANY(sv) = new_XPVBM();
1148 SvMAGIC(sv) = magic;
1149 SvSTASH(sv) = stash;
1155 SvANY(sv) = new_XPVFM();
1156 Zero(SvANY(sv), 1, XPVFM);
1162 SvMAGIC(sv) = magic;
1163 SvSTASH(sv) = stash;
1166 SvANY(sv) = new_XPVIO();
1167 Zero(SvANY(sv), 1, XPVIO);
1173 SvMAGIC(sv) = magic;
1174 SvSTASH(sv) = stash;
1175 IoPAGE_LEN(sv) = 60;
1178 SvFLAGS(sv) &= ~SVTYPEMASK;
1184 Perl_sv_backoff(pTHX_ register SV *sv)
1188 char *s = SvPVX(sv);
1189 SvLEN(sv) += SvIVX(sv);
1190 SvPVX(sv) -= SvIVX(sv);
1192 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1194 SvFLAGS(sv) &= ~SVf_OOK;
1201 Expands the character buffer in the SV. This will use C<sv_unref> and will
1202 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1209 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1213 #ifdef HAS_64K_LIMIT
1214 if (newlen >= 0x10000) {
1215 PerlIO_printf(Perl_debug_log,
1216 "Allocation too large: %"UVxf"\n", (UV)newlen);
1219 #endif /* HAS_64K_LIMIT */
1222 if (SvTYPE(sv) < SVt_PV) {
1223 sv_upgrade(sv, SVt_PV);
1226 else if (SvOOK(sv)) { /* pv is offset? */
1229 if (newlen > SvLEN(sv))
1230 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1231 #ifdef HAS_64K_LIMIT
1232 if (newlen >= 0x10000)
1238 if (newlen > SvLEN(sv)) { /* need more room? */
1239 if (SvLEN(sv) && s) {
1240 #if defined(MYMALLOC) && !defined(LEAKTEST)
1241 STRLEN l = malloced_size((void*)SvPVX(sv));
1247 Renew(s,newlen,char);
1250 New(703,s,newlen,char);
1252 SvLEN_set(sv, newlen);
1258 =for apidoc sv_setiv
1260 Copies an integer into the given SV. Does not handle 'set' magic. See
1267 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1269 SV_CHECK_THINKFIRST(sv);
1270 switch (SvTYPE(sv)) {
1272 sv_upgrade(sv, SVt_IV);
1275 sv_upgrade(sv, SVt_PVNV);
1279 sv_upgrade(sv, SVt_PVIV);
1288 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1289 PL_op_desc[PL_op->op_type]);
1291 (void)SvIOK_only(sv); /* validate number */
1297 =for apidoc sv_setiv_mg
1299 Like C<sv_setiv>, but also handles 'set' magic.
1305 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1312 =for apidoc sv_setuv
1314 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1321 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1323 /* With these two if statements:
1324 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1327 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1329 If you wish to remove them, please benchmark to see what the effect is
1331 if (u <= (UV)IV_MAX) {
1332 sv_setiv(sv, (IV)u);
1341 =for apidoc sv_setuv_mg
1343 Like C<sv_setuv>, but also handles 'set' magic.
1349 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1351 /* With these two if statements:
1352 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1355 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1357 If you wish to remove them, please benchmark to see what the effect is
1359 if (u <= (UV)IV_MAX) {
1360 sv_setiv(sv, (IV)u);
1370 =for apidoc sv_setnv
1372 Copies a double into the given SV. Does not handle 'set' magic. See
1379 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1381 SV_CHECK_THINKFIRST(sv);
1382 switch (SvTYPE(sv)) {
1385 sv_upgrade(sv, SVt_NV);
1390 sv_upgrade(sv, SVt_PVNV);
1399 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1400 PL_op_name[PL_op->op_type]);
1403 (void)SvNOK_only(sv); /* validate number */
1408 =for apidoc sv_setnv_mg
1410 Like C<sv_setnv>, but also handles 'set' magic.
1416 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1423 S_not_a_number(pTHX_ SV *sv)
1428 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1429 /* each *s can expand to 4 chars + "...\0",
1430 i.e. need room for 8 chars */
1432 for (s = SvPVX(sv); *s && d < limit; s++) {
1434 if (ch & 128 && !isPRINT_LC(ch)) {
1443 else if (ch == '\r') {
1447 else if (ch == '\f') {
1451 else if (ch == '\\') {
1455 else if (isPRINT_LC(ch))
1470 Perl_warner(aTHX_ WARN_NUMERIC,
1471 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1472 PL_op_desc[PL_op->op_type]);
1474 Perl_warner(aTHX_ WARN_NUMERIC,
1475 "Argument \"%s\" isn't numeric", tmpbuf);
1478 /* the number can be converted to integer with atol() or atoll() although */
1479 #define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
1480 #define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
1481 #define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
1482 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1483 #define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
1484 #define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
1485 #define IS_NUMBER_NEG 0x40 /* seen a leading - */
1486 #define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
1488 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1489 until proven guilty, assume that things are not that bad... */
1491 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1492 an IV (an assumption perl has been based on to date) it becomes necessary
1493 to remove the assumption that the NV always carries enough precision to
1494 recreate the IV whenever needed, and that the NV is the canonical form.
1495 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1496 precision as an side effect of conversion (which would lead to insanity
1497 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1498 1) to distinguish between IV/UV/NV slots that have cached a valid
1499 conversion where precision was lost and IV/UV/NV slots that have a
1500 valid conversion which has lost no precision
1501 2) to ensure that if a numeric conversion to one form is request that
1502 would lose precision, the precise conversion (or differently
1503 imprecise conversion) is also performed and cached, to prevent
1504 requests for different numeric formats on the same SV causing
1505 lossy conversion chains. (lossless conversion chains are perfectly
1510 SvIOKp is true if the IV slot contains a valid value
1511 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1512 SvNOKp is true if the NV slot contains a valid value
1513 SvNOK is true only if the NV value is accurate
1516 while converting from PV to NV check to see if converting that NV to an
1517 IV(or UV) would lose accuracy over a direct conversion from PV to
1518 IV(or UV). If it would, cache both conversions, return NV, but mark
1519 SV as IOK NOKp (ie not NOK).
1521 while converting from PV to IV check to see if converting that IV to an
1522 NV would lose accuracy over a direct conversion from PV to NV. If it
1523 would, cache both conversions, flag similarly.
1525 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1526 correctly because if IV & NV were set NV *always* overruled.
1527 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1528 changes - now IV and NV together means that the two are interchangeable
1529 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1531 The benefit of this is operations such as pp_add know that if SvIOK is
1532 true for both left and right operands, then integer addition can be
1533 used instead of floating point. (for cases where the result won't
1534 overflow) Before, floating point was always used, which could lead to
1535 loss of precision compared with integer addition.
1537 * making IV and NV equal status should make maths accurate on 64 bit
1539 * may speed up maths somewhat if pp_add and friends start to use
1540 integers when possible instead of fp. (hopefully the overhead in
1541 looking for SvIOK and checking for overflow will not outweigh the
1542 fp to integer speedup)
1543 * will slow down integer operations (callers of SvIV) on "inaccurate"
1544 values, as the change from SvIOK to SvIOKp will cause a call into
1545 sv_2iv each time rather than a macro access direct to the IV slot
1546 * should speed up number->string conversion on integers as IV is
1547 favoured when IV and NV equally accurate
1549 ####################################################################
1550 You had better be using SvIOK_notUV if you want an IV for arithmetic
1551 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1552 SvUOK is true iff UV.
1553 ####################################################################
1555 Your mileage will vary depending your CPUs relative fp to integer
1559 #ifndef NV_PRESERVES_UV
1560 #define IS_NUMBER_UNDERFLOW_IV 1
1561 #define IS_NUMBER_UNDERFLOW_UV 2
1562 #define IS_NUMBER_IV_AND_UV 2
1563 #define IS_NUMBER_OVERFLOW_IV 4
1564 #define IS_NUMBER_OVERFLOW_UV 5
1565 /* Hopefully your optimiser will consider inlining these two functions. */
1567 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1568 NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
1569 UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
1570 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, numtype));
1571 if (nv_as_uv <= (UV)IV_MAX) {
1572 (void)SvIOKp_on(sv);
1573 (void)SvNOKp_on(sv);
1574 /* Within suitable range to fit in an IV, atol won't overflow */
1575 /* XXX quite sure? Is that your final answer? not really, I'm
1576 trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1577 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1578 if (numtype & IS_NUMBER_NOT_INT) {
1579 /* I believe that even if the original PV had decimals, they
1580 are lost beyond the limit of the FP precision.
1581 However, neither is canonical, so both only get p flags.
1583 /* Both already have p flags, so do nothing */
1584 } else if (SvIVX(sv) == I_V(nv)) {
1589 /* It had no "." so it must be integer. assert (get in here from
1590 sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1591 IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1592 conversion routines need audit. */
1594 return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1596 /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1597 (void)SvIOKp_on(sv);
1598 (void)SvNOKp_on(sv);
1601 int save_errno = errno;
1603 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1605 if (numtype & IS_NUMBER_NOT_INT) {
1606 /* UV and NV both imprecise. */
1608 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1617 return IS_NUMBER_OVERFLOW_IV;
1621 /* Must have just overflowed UV, but not enough that an NV could spot
1623 return IS_NUMBER_OVERFLOW_UV;
1626 /* We've just lost integer precision, nothing we could do. */
1627 SvUVX(sv) = nv_as_uv;
1628 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%X\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, numtype));
1629 /* UV and NV slots equally valid only if we have casting symmetry. */
1630 if (numtype & IS_NUMBER_NOT_INT) {
1632 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1633 /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1634 UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1635 get to this point if NVs don't preserve UVs) */
1640 /* As above, I believe UV at least as good as NV */
1643 #endif /* HAS_STRTOUL */
1644 return IS_NUMBER_OVERFLOW_IV;
1647 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1649 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1651 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%X\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), numtype));
1652 if (SvNVX(sv) < (NV)IV_MIN) {
1653 (void)SvIOKp_on(sv);
1656 return IS_NUMBER_UNDERFLOW_IV;
1658 if (SvNVX(sv) > (NV)UV_MAX) {
1659 (void)SvIOKp_on(sv);
1663 return IS_NUMBER_OVERFLOW_UV;
1665 if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1666 (void)SvIOKp_on(sv);
1668 /* Can't use strtol etc to convert this string */
1669 if (SvNVX(sv) <= (UV)IV_MAX) {
1670 SvIVX(sv) = I_V(SvNVX(sv));
1671 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1672 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1674 /* Integer is imprecise. NOK, IOKp */
1676 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1679 SvUVX(sv) = U_V(SvNVX(sv));
1680 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1681 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1683 /* Integer is imprecise. NOK, IOKp */
1685 return IS_NUMBER_OVERFLOW_IV;
1687 return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
1689 #endif /* NV_PRESERVES_UV*/
1692 Perl_sv_2iv(pTHX_ register SV *sv)
1696 if (SvGMAGICAL(sv)) {
1701 return I_V(SvNVX(sv));
1703 if (SvPOKp(sv) && SvLEN(sv))
1706 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1707 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1713 if (SvTHINKFIRST(sv)) {
1716 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1717 (SvRV(tmpstr) != SvRV(sv)))
1718 return SvIV(tmpstr);
1719 return PTR2IV(SvRV(sv));
1721 if (SvREADONLY(sv) && SvFAKE(sv)) {
1722 sv_force_normal(sv);
1724 if (SvREADONLY(sv) && !SvOK(sv)) {
1725 if (ckWARN(WARN_UNINITIALIZED))
1732 return (IV)(SvUVX(sv));
1739 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1740 * without also getting a cached IV/UV from it at the same time
1741 * (ie PV->NV conversion should detect loss of accuracy and cache
1742 * IV or UV at same time to avoid this. NWC */
1744 if (SvTYPE(sv) == SVt_NV)
1745 sv_upgrade(sv, SVt_PVNV);
1747 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1748 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1749 certainly cast into the IV range at IV_MAX, whereas the correct
1750 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1752 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1753 SvIVX(sv) = I_V(SvNVX(sv));
1754 if (SvNVX(sv) == (NV) SvIVX(sv)
1755 #ifndef NV_PRESERVES_UV
1756 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1757 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1758 /* Don't flag it as "accurately an integer" if the number
1759 came from a (by definition imprecise) NV operation, and
1760 we're outside the range of NV integer precision */
1763 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1764 DEBUG_c(PerlIO_printf(Perl_debug_log,
1765 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1771 /* IV not precise. No need to convert from PV, as NV
1772 conversion would already have cached IV if it detected
1773 that PV->IV would be better than PV->NV->IV
1774 flags already correct - don't set public IOK. */
1775 DEBUG_c(PerlIO_printf(Perl_debug_log,
1776 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1781 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1782 but the cast (NV)IV_MIN rounds to a the value less (more
1783 negative) than IV_MIN which happens to be equal to SvNVX ??
1784 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1785 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1786 (NV)UVX == NVX are both true, but the values differ. :-(
1787 Hopefully for 2s complement IV_MIN is something like
1788 0x8000000000000000 which will be exact. NWC */
1791 SvUVX(sv) = U_V(SvNVX(sv));
1793 (SvNVX(sv) == (NV) SvUVX(sv))
1794 #ifndef NV_PRESERVES_UV
1795 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1796 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1797 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1798 /* Don't flag it as "accurately an integer" if the number
1799 came from a (by definition imprecise) NV operation, and
1800 we're outside the range of NV integer precision */
1806 DEBUG_c(PerlIO_printf(Perl_debug_log,
1807 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1811 return (IV)SvUVX(sv);
1814 else if (SvPOKp(sv) && SvLEN(sv)) {
1815 I32 numtype = looks_like_number(sv);
1817 /* We want to avoid a possible problem when we cache an IV which
1818 may be later translated to an NV, and the resulting NV is not
1819 the translation of the initial data.
1821 This means that if we cache such an IV, we need to cache the
1822 NV as well. Moreover, we trade speed for space, and do not
1823 cache the NV if we are sure it's not needed.
1826 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1827 /* The NV may be reconstructed from IV - safe to cache IV,
1828 which may be calculated by atol(). */
1829 if (SvTYPE(sv) < SVt_PVIV)
1830 sv_upgrade(sv, SVt_PVIV);
1832 SvIVX(sv) = Atol(SvPVX(sv));
1836 int save_errno = errno;
1837 /* Is it an integer that we could convert with strtol?
1838 So try it, and if it doesn't set errno then it's pukka.
1839 This should be faster than going atof and then thinking. */
1840 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1841 == IS_NUMBER_TO_INT_BY_STRTOL)
1842 /* && is a sequence point. Without it not sure if I'm trying
1843 to do too much between sequence points and hence going
1845 && ((errno = 0), 1) /* , 1 so always true */
1846 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1848 if (SvTYPE(sv) < SVt_PVIV)
1849 sv_upgrade(sv, SVt_PVIV);
1858 /* Hopefully trace flow will optimise this away where possible
1862 /* It wasn't an integer, or it overflowed, or we don't have
1863 strtol. Do things the slow way - check if it's a UV etc. */
1864 d = Atof(SvPVX(sv));
1866 if (SvTYPE(sv) < SVt_PVNV)
1867 sv_upgrade(sv, SVt_PVNV);
1870 if (! numtype && ckWARN(WARN_NUMERIC))
1873 #if defined(USE_LONG_DOUBLE)
1874 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1875 PTR2UV(sv), SvNVX(sv)));
1877 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1878 PTR2UV(sv), SvNVX(sv)));
1882 #ifdef NV_PRESERVES_UV
1883 (void)SvIOKp_on(sv);
1885 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1886 SvIVX(sv) = I_V(SvNVX(sv));
1887 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1890 /* Integer is imprecise. NOK, IOKp */
1892 /* UV will not work better than IV */
1894 if (SvNVX(sv) > (NV)UV_MAX) {
1896 /* Integer is inaccurate. NOK, IOKp, is UV */
1900 SvUVX(sv) = U_V(SvNVX(sv));
1901 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1902 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1906 /* Integer is imprecise. NOK, IOKp, is UV */
1912 #else /* NV_PRESERVES_UV */
1913 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1914 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1915 /* Small enough to preserve all bits. */
1916 (void)SvIOKp_on(sv);
1918 SvIVX(sv) = I_V(SvNVX(sv));
1919 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1921 /* Assumption: first non-preserved integer is < IV_MAX,
1922 this NV is in the preserved range, therefore: */
1923 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1925 Perl_croak(aTHX_ "sv_2iv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
1927 } else if (sv_2iuv_non_preserve (sv, numtype)
1928 >= IS_NUMBER_OVERFLOW_IV)
1930 #endif /* NV_PRESERVES_UV */
1934 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1936 if (SvTYPE(sv) < SVt_IV)
1937 /* Typically the caller expects that sv_any is not NULL now. */
1938 sv_upgrade(sv, SVt_IV);
1941 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1942 PTR2UV(sv),SvIVX(sv)));
1943 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1947 Perl_sv_2uv(pTHX_ register SV *sv)
1951 if (SvGMAGICAL(sv)) {
1956 return U_V(SvNVX(sv));
1957 if (SvPOKp(sv) && SvLEN(sv))
1960 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1961 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1967 if (SvTHINKFIRST(sv)) {
1970 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1971 (SvRV(tmpstr) != SvRV(sv)))
1972 return SvUV(tmpstr);
1973 return PTR2UV(SvRV(sv));
1975 if (SvREADONLY(sv) && SvFAKE(sv)) {
1976 sv_force_normal(sv);
1978 if (SvREADONLY(sv) && !SvOK(sv)) {
1979 if (ckWARN(WARN_UNINITIALIZED))
1989 return (UV)SvIVX(sv);
1993 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1994 * without also getting a cached IV/UV from it at the same time
1995 * (ie PV->NV conversion should detect loss of accuracy and cache
1996 * IV or UV at same time to avoid this. */
1997 /* IV-over-UV optimisation - choose to cache IV if possible */
1999 if (SvTYPE(sv) == SVt_NV)
2000 sv_upgrade(sv, SVt_PVNV);
2002 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2003 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2004 SvIVX(sv) = I_V(SvNVX(sv));
2005 if (SvNVX(sv) == (NV) SvIVX(sv)
2006 #ifndef NV_PRESERVES_UV
2007 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2008 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2009 /* Don't flag it as "accurately an integer" if the number
2010 came from a (by definition imprecise) NV operation, and
2011 we're outside the range of NV integer precision */
2014 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2015 DEBUG_c(PerlIO_printf(Perl_debug_log,
2016 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2022 /* IV not precise. No need to convert from PV, as NV
2023 conversion would already have cached IV if it detected
2024 that PV->IV would be better than PV->NV->IV
2025 flags already correct - don't set public IOK. */
2026 DEBUG_c(PerlIO_printf(Perl_debug_log,
2027 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2032 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2033 but the cast (NV)IV_MIN rounds to a the value less (more
2034 negative) than IV_MIN which happens to be equal to SvNVX ??
2035 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2036 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2037 (NV)UVX == NVX are both true, but the values differ. :-(
2038 Hopefully for 2s complement IV_MIN is something like
2039 0x8000000000000000 which will be exact. NWC */
2042 SvUVX(sv) = U_V(SvNVX(sv));
2044 (SvNVX(sv) == (NV) SvUVX(sv))
2045 #ifndef NV_PRESERVES_UV
2046 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2047 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2048 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2049 /* Don't flag it as "accurately an integer" if the number
2050 came from a (by definition imprecise) NV operation, and
2051 we're outside the range of NV integer precision */
2056 DEBUG_c(PerlIO_printf(Perl_debug_log,
2057 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2063 else if (SvPOKp(sv) && SvLEN(sv)) {
2064 I32 numtype = looks_like_number(sv);
2066 /* We want to avoid a possible problem when we cache a UV which
2067 may be later translated to an NV, and the resulting NV is not
2068 the translation of the initial data.
2070 This means that if we cache such a UV, we need to cache the
2071 NV as well. Moreover, we trade speed for space, and do not
2072 cache the NV if not needed.
2075 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2076 /* The NV may be reconstructed from IV - safe to cache IV,
2077 which may be calculated by atol(). */
2078 if (SvTYPE(sv) < SVt_PVIV)
2079 sv_upgrade(sv, SVt_PVIV);
2081 SvIVX(sv) = Atol(SvPVX(sv));
2085 char *num_begin = SvPVX(sv);
2086 int save_errno = errno;
2088 /* seems that strtoul taking numbers that start with - is
2089 implementation dependant, and can't be relied upon. */
2090 if (numtype & IS_NUMBER_NEG) {
2091 /* Not totally defensive. assumine that looks_like_num
2092 didn't lie about a - sign */
2093 while (isSPACE(*num_begin))
2095 if (*num_begin == '-')
2099 /* Is it an integer that we could convert with strtoul?
2100 So try it, and if it doesn't set errno then it's pukka.
2101 This should be faster than going atof and then thinking. */
2102 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2103 == IS_NUMBER_TO_INT_BY_STRTOL)
2104 && ((errno = 0), 1) /* always true */
2105 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2107 /* If known to be negative, check it didn't undeflow IV
2108 XXX possibly we should put more negative values as NVs
2109 direct rather than go via atof below */
2110 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2113 if (SvTYPE(sv) < SVt_PVIV)
2114 sv_upgrade(sv, SVt_PVIV);
2117 /* If it's negative must use IV.
2118 IV-over-UV optimisation */
2119 if (numtype & IS_NUMBER_NEG) {
2121 } else if (u <= (UV) IV_MAX) {
2124 /* it didn't overflow, and it was positive. */
2133 /* Hopefully trace flow will optimise this away where possible
2137 /* It wasn't an integer, or it overflowed, or we don't have
2138 strtol. Do things the slow way - check if it's a IV etc. */
2139 d = Atof(SvPVX(sv));
2141 if (SvTYPE(sv) < SVt_PVNV)
2142 sv_upgrade(sv, SVt_PVNV);
2145 if (! numtype && ckWARN(WARN_NUMERIC))
2148 #if defined(USE_LONG_DOUBLE)
2149 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2150 PTR2UV(sv), SvNVX(sv)));
2152 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2153 PTR2UV(sv), SvNVX(sv)));
2156 #ifdef NV_PRESERVES_UV
2157 (void)SvIOKp_on(sv);
2159 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2160 SvIVX(sv) = I_V(SvNVX(sv));
2161 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2164 /* Integer is imprecise. NOK, IOKp */
2166 /* UV will not work better than IV */
2168 if (SvNVX(sv) > (NV)UV_MAX) {
2170 /* Integer is inaccurate. NOK, IOKp, is UV */
2174 SvUVX(sv) = U_V(SvNVX(sv));
2175 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2176 NV preservse UV so can do correct comparison. */
2177 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2181 /* Integer is imprecise. NOK, IOKp, is UV */
2186 #else /* NV_PRESERVES_UV */
2187 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2188 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2189 /* Small enough to preserve all bits. */
2190 (void)SvIOKp_on(sv);
2192 SvIVX(sv) = I_V(SvNVX(sv));
2193 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2195 /* Assumption: first non-preserved integer is < IV_MAX,
2196 this NV is in the preserved range, therefore: */
2197 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2199 Perl_croak(aTHX_ "sv_2uv assumed (U_V(fabs(SvNVX(sv))) < (UV)IV_MAX) but SvNVX(sv)=%g U_V is 0x%"UVxf", IV_MAX is 0x%"UVxf"\n", SvNVX(sv), U_V(SvNVX(sv)), (UV)IV_MAX);
2202 sv_2iuv_non_preserve (sv, numtype);
2203 #endif /* NV_PRESERVES_UV */
2208 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2209 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2212 if (SvTYPE(sv) < SVt_IV)
2213 /* Typically the caller expects that sv_any is not NULL now. */
2214 sv_upgrade(sv, SVt_IV);
2218 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2219 PTR2UV(sv),SvUVX(sv)));
2220 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2224 Perl_sv_2nv(pTHX_ register SV *sv)
2228 if (SvGMAGICAL(sv)) {
2232 if (SvPOKp(sv) && SvLEN(sv)) {
2233 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2235 return Atof(SvPVX(sv));
2239 return (NV)SvUVX(sv);
2241 return (NV)SvIVX(sv);
2244 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2245 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2251 if (SvTHINKFIRST(sv)) {
2254 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2255 (SvRV(tmpstr) != SvRV(sv)))
2256 return SvNV(tmpstr);
2257 return PTR2NV(SvRV(sv));
2259 if (SvREADONLY(sv) && SvFAKE(sv)) {
2260 sv_force_normal(sv);
2262 if (SvREADONLY(sv) && !SvOK(sv)) {
2263 if (ckWARN(WARN_UNINITIALIZED))
2268 if (SvTYPE(sv) < SVt_NV) {
2269 if (SvTYPE(sv) == SVt_IV)
2270 sv_upgrade(sv, SVt_PVNV);
2272 sv_upgrade(sv, SVt_NV);
2273 #if defined(USE_LONG_DOUBLE)
2275 STORE_NUMERIC_LOCAL_SET_STANDARD();
2276 PerlIO_printf(Perl_debug_log,
2277 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2278 PTR2UV(sv), SvNVX(sv));
2279 RESTORE_NUMERIC_LOCAL();
2283 STORE_NUMERIC_LOCAL_SET_STANDARD();
2284 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2285 PTR2UV(sv), SvNVX(sv));
2286 RESTORE_NUMERIC_LOCAL();
2290 else if (SvTYPE(sv) < SVt_PVNV)
2291 sv_upgrade(sv, SVt_PVNV);
2293 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2295 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2296 #ifdef NV_PRESERVES_UV
2299 /* Only set the public NV OK flag if this NV preserves the IV */
2300 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2301 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2302 : (SvIVX(sv) == I_V(SvNVX(sv))))
2308 else if (SvPOKp(sv) && SvLEN(sv)) {
2309 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2311 SvNVX(sv) = Atof(SvPVX(sv));
2312 #ifdef NV_PRESERVES_UV
2315 /* Only set the public NV OK flag if this NV preserves the value in
2316 the PV at least as well as an IV/UV would.
2317 Not sure how to do this 100% reliably. */
2318 /* if that shift count is out of range then Configure's test is
2319 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2321 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2322 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2323 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2324 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2325 /* Definitely too large/small to fit in an integer, so no loss
2326 of precision going to integer in the future via NV */
2329 /* Is it something we can run through strtol etc (ie no
2330 trailing exponent part)? */
2331 int numtype = looks_like_number(sv);
2332 /* XXX probably should cache this if called above */
2335 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2336 /* Can't use strtol etc to convert this string, so don't try */
2339 sv_2inuv_non_preserve (sv, numtype);
2341 #endif /* NV_PRESERVES_UV */
2344 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2346 if (SvTYPE(sv) < SVt_NV)
2347 /* Typically the caller expects that sv_any is not NULL now. */
2348 /* XXX Ilya implies that this is a bug in callers that assume this
2349 and ideally should be fixed. */
2350 sv_upgrade(sv, SVt_NV);
2353 #if defined(USE_LONG_DOUBLE)
2355 STORE_NUMERIC_LOCAL_SET_STANDARD();
2356 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2357 PTR2UV(sv), SvNVX(sv));
2358 RESTORE_NUMERIC_LOCAL();
2362 STORE_NUMERIC_LOCAL_SET_STANDARD();
2363 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2364 PTR2UV(sv), SvNVX(sv));
2365 RESTORE_NUMERIC_LOCAL();
2372 S_asIV(pTHX_ SV *sv)
2374 I32 numtype = looks_like_number(sv);
2377 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2378 return Atol(SvPVX(sv));
2380 if (ckWARN(WARN_NUMERIC))
2383 d = Atof(SvPVX(sv));
2388 S_asUV(pTHX_ SV *sv)
2390 I32 numtype = looks_like_number(sv);
2393 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2394 return Strtoul(SvPVX(sv), Null(char**), 10);
2397 if (ckWARN(WARN_NUMERIC))
2400 return U_V(Atof(SvPVX(sv)));
2404 * Returns a combination of (advisory only - can get false negatives)
2405 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2406 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2407 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2408 * 0 if does not look like number.
2410 * (atol and strtol stop when they hit a decimal point. strtol will return
2411 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2412 * do this, and vendors have had 11 years to get it right.
2413 * However, will try to make it still work with only atol
2415 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2416 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2417 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2418 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2419 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2420 * IS_NUMBER_NOT_INT saw "." or "e"
2422 * IS_NUMBER_INFINITY
2426 =for apidoc looks_like_number
2428 Test if an the content of an SV looks like a number (or is a
2429 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2430 issue a non-numeric warning), even if your atof() doesn't grok them.
2436 Perl_looks_like_number(pTHX_ SV *sv)
2439 register char *send;
2440 register char *sbegin;
2441 register char *nbegin;
2450 else if (SvPOKp(sv))
2451 sbegin = SvPV(sv, len);
2454 send = sbegin + len;
2461 numtype = IS_NUMBER_NEG;
2468 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2469 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2470 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2471 * will need (int)atof().
2474 /* next must be digit or the radix separator or beginning of infinity */
2478 } while (isDIGIT(*s));
2480 /* Aaargh. long long really is irritating.
2481 In the gospel according to ANSI 1989, it is an axiom that "long"
2482 is the longest integer type, and that if you don't know how long
2483 something is you can cast it to long, and nothing will be lost
2484 (except possibly speed of execution if long is slower than the
2486 Now, one can't be sure if the old rules apply, or long long
2487 (or some other newfangled thing) is actually longer than the
2488 (formerly) longest thing.
2490 /* This lot will work for 64 bit *as long as* either
2491 either long is 64 bit
2492 or we can find both strtol/strtoq and strtoul/strtouq
2493 If not, we really should refuse to let the user use 64 bit IVs
2494 By "64 bit" I really mean IVs that don't get preserved by NVs
2495 It also should work for 128 bit IVs. Can any lend me a machine to
2498 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2499 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2500 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2501 ? sizeof(long) : sizeof (IV))*8-1))
2502 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2504 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2505 digit less (IV_MAX= 9223372036854775807,
2506 UV_MAX= 18446744073709551615) so be cautious */
2507 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2510 #ifdef USE_LOCALE_NUMERIC
2511 || IS_NUMERIC_RADIX(*s)
2515 numtype |= IS_NUMBER_NOT_INT;
2516 while (isDIGIT(*s)) /* optional digits after the radix */
2521 #ifdef USE_LOCALE_NUMERIC
2522 || IS_NUMERIC_RADIX(*s)
2526 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2527 /* no digits before the radix means we need digits after it */
2531 } while (isDIGIT(*s));
2536 else if (*s == 'I' || *s == 'i') {
2537 s++; if (*s != 'N' && *s != 'n') return 0;
2538 s++; if (*s != 'F' && *s != 'f') return 0;
2539 s++; if (*s == 'I' || *s == 'i') {
2540 s++; if (*s != 'N' && *s != 'n') return 0;
2541 s++; if (*s != 'I' && *s != 'i') return 0;
2542 s++; if (*s != 'T' && *s != 't') return 0;
2543 s++; if (*s != 'Y' && *s != 'y') return 0;
2552 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2553 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2555 /* we can have an optional exponent part */
2556 if (*s == 'e' || *s == 'E') {
2557 numtype &= IS_NUMBER_NEG;
2558 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2560 if (*s == '+' || *s == '-')
2565 } while (isDIGIT(*s));
2575 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2576 return IS_NUMBER_TO_INT_BY_ATOL;
2581 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2584 return sv_2pv(sv, &n_a);
2587 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2589 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2591 char *ptr = buf + TYPE_CHARS(UV);
2605 *--ptr = '0' + (uv % 10);
2614 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2619 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2620 char *tmpbuf = tbuf;
2626 if (SvGMAGICAL(sv)) {
2634 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2636 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2641 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2646 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2647 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2654 if (SvTHINKFIRST(sv)) {
2657 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2658 (SvRV(tmpstr) != SvRV(sv)))
2659 return SvPV(tmpstr,*lp);
2666 switch (SvTYPE(sv)) {
2668 if ( ((SvFLAGS(sv) &
2669 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2670 == (SVs_OBJECT|SVs_RMG))
2671 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2672 && (mg = mg_find(sv, 'r'))) {
2673 regexp *re = (regexp *)mg->mg_obj;
2676 char *fptr = "msix";
2681 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2683 while((ch = *fptr++)) {
2685 reflags[left++] = ch;
2688 reflags[right--] = ch;
2693 reflags[left] = '-';
2697 mg->mg_len = re->prelen + 4 + left;
2698 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2699 Copy("(?", mg->mg_ptr, 2, char);
2700 Copy(reflags, mg->mg_ptr+2, left, char);
2701 Copy(":", mg->mg_ptr+left+2, 1, char);
2702 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2703 mg->mg_ptr[mg->mg_len - 1] = ')';
2704 mg->mg_ptr[mg->mg_len] = 0;
2706 PL_reginterp_cnt += re->program[0].next_off;
2718 case SVt_PVBM: if (SvROK(sv))
2721 s = "SCALAR"; break;
2722 case SVt_PVLV: s = "LVALUE"; break;
2723 case SVt_PVAV: s = "ARRAY"; break;
2724 case SVt_PVHV: s = "HASH"; break;
2725 case SVt_PVCV: s = "CODE"; break;
2726 case SVt_PVGV: s = "GLOB"; break;
2727 case SVt_PVFM: s = "FORMAT"; break;
2728 case SVt_PVIO: s = "IO"; break;
2729 default: s = "UNKNOWN"; break;
2733 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2736 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2742 if (SvREADONLY(sv) && !SvOK(sv)) {
2743 if (ckWARN(WARN_UNINITIALIZED))
2749 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2750 /* I'm assuming that if both IV and NV are equally valid then
2751 converting the IV is going to be more efficient */
2752 U32 isIOK = SvIOK(sv);
2753 U32 isUIOK = SvIsUV(sv);
2754 char buf[TYPE_CHARS(UV)];
2757 if (SvTYPE(sv) < SVt_PVIV)
2758 sv_upgrade(sv, SVt_PVIV);
2760 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2762 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2763 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2764 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2765 SvCUR_set(sv, ebuf - ptr);
2775 else if (SvNOKp(sv)) {
2776 if (SvTYPE(sv) < SVt_PVNV)
2777 sv_upgrade(sv, SVt_PVNV);
2778 /* The +20 is pure guesswork. Configure test needed. --jhi */
2779 SvGROW(sv, NV_DIG + 20);
2781 olderrno = errno; /* some Xenix systems wipe out errno here */
2783 if (SvNVX(sv) == 0.0)
2784 (void)strcpy(s,"0");
2788 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2791 #ifdef FIXNEGATIVEZERO
2792 if (*s == '-' && s[1] == '0' && !s[2])
2802 if (ckWARN(WARN_UNINITIALIZED)
2803 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2806 if (SvTYPE(sv) < SVt_PV)
2807 /* Typically the caller expects that sv_any is not NULL now. */
2808 sv_upgrade(sv, SVt_PV);
2811 *lp = s - SvPVX(sv);
2814 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2815 PTR2UV(sv),SvPVX(sv)));
2819 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2820 /* Sneaky stuff here */
2824 tsv = newSVpv(tmpbuf, 0);
2840 len = strlen(tmpbuf);
2842 #ifdef FIXNEGATIVEZERO
2843 if (len == 2 && t[0] == '-' && t[1] == '0') {
2848 (void)SvUPGRADE(sv, SVt_PV);
2850 s = SvGROW(sv, len + 1);
2859 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2862 return sv_2pvbyte(sv, &n_a);
2866 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2868 return sv_2pv(sv,lp);
2872 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2875 return sv_2pvutf8(sv, &n_a);
2879 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2881 sv_utf8_upgrade(sv);
2882 return SvPV(sv,*lp);
2885 /* This function is only called on magical items */
2887 Perl_sv_2bool(pTHX_ register SV *sv)
2896 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2897 (SvRV(tmpsv) != SvRV(sv)))
2898 return SvTRUE(tmpsv);
2899 return SvRV(sv) != 0;
2902 register XPV* Xpvtmp;
2903 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2904 (*Xpvtmp->xpv_pv > '0' ||
2905 Xpvtmp->xpv_cur > 1 ||
2906 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2913 return SvIVX(sv) != 0;
2916 return SvNVX(sv) != 0.0;
2924 =for apidoc sv_utf8_upgrade
2926 Convert the PV of an SV to its UTF8-encoded form.
2932 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2937 if (!sv || !SvPOK(sv) || !SvCUR(sv) || SvUTF8(sv))
2940 /* This function could be much more efficient if we had a FLAG in SVs
2941 * to signal if there are any hibit chars in the PV.
2942 * Given that there isn't make loop fast as possible
2948 if ((hibit = *t++ & 0x80))
2954 if (SvREADONLY(sv) && SvFAKE(sv)) {
2955 sv_force_normal(sv);
2958 len = SvCUR(sv) + 1; /* Plus the \0 */
2959 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2960 SvCUR(sv) = len - 1;
2962 Safefree(s); /* No longer using what was there before. */
2963 SvLEN(sv) = len; /* No longer know the real size. */
2969 =for apidoc sv_utf8_downgrade
2971 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
2972 This may not be possible if the PV contains non-byte encoding characters;
2973 if this is the case, either returns false or, if C<fail_ok> is not
2980 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
2982 if (SvPOK(sv) && SvUTF8(sv)) {
2984 char *c = SvPVX(sv);
2985 STRLEN len = SvCUR(sv);
2987 if (!utf8_to_bytes((U8*)c, &len)) {
2992 Perl_croak(aTHX_ "Wide character in %s",
2993 PL_op_desc[PL_op->op_type]);
2995 Perl_croak(aTHX_ "Wide character");
3007 =for apidoc sv_utf8_encode
3009 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3010 flag so that it looks like bytes again. Nothing calls this.
3016 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3018 sv_utf8_upgrade(sv);
3023 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3028 bool has_utf = FALSE;
3029 if (!sv_utf8_downgrade(sv, TRUE))
3032 /* it is actually just a matter of turning the utf8 flag on, but
3033 * we want to make sure everything inside is valid utf8 first.
3036 if (!is_utf8_string((U8*)c, SvCUR(sv)+1))
3050 /* Note: sv_setsv() should not be called with a source string that needs
3051 * to be reused, since it may destroy the source string if it is marked
3056 =for apidoc sv_setsv
3058 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3059 The source SV may be destroyed if it is mortal. Does not handle 'set'
3060 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3067 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3069 register U32 sflags;
3075 SV_CHECK_THINKFIRST(dstr);
3077 sstr = &PL_sv_undef;
3078 stype = SvTYPE(sstr);
3079 dtype = SvTYPE(dstr);
3083 /* There's a lot of redundancy below but we're going for speed here */
3088 if (dtype != SVt_PVGV) {
3089 (void)SvOK_off(dstr);
3097 sv_upgrade(dstr, SVt_IV);
3100 sv_upgrade(dstr, SVt_PVNV);
3104 sv_upgrade(dstr, SVt_PVIV);
3107 (void)SvIOK_only(dstr);
3108 SvIVX(dstr) = SvIVX(sstr);
3111 if (SvTAINTED(sstr))
3122 sv_upgrade(dstr, SVt_NV);
3127 sv_upgrade(dstr, SVt_PVNV);
3130 SvNVX(dstr) = SvNVX(sstr);
3131 (void)SvNOK_only(dstr);
3132 if (SvTAINTED(sstr))
3140 sv_upgrade(dstr, SVt_RV);
3141 else if (dtype == SVt_PVGV &&
3142 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3145 if (GvIMPORTED(dstr) != GVf_IMPORTED
3146 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3148 GvIMPORTED_on(dstr);
3159 sv_upgrade(dstr, SVt_PV);
3162 if (dtype < SVt_PVIV)
3163 sv_upgrade(dstr, SVt_PVIV);
3166 if (dtype < SVt_PVNV)
3167 sv_upgrade(dstr, SVt_PVNV);
3174 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3175 PL_op_name[PL_op->op_type]);
3177 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3181 if (dtype <= SVt_PVGV) {
3183 if (dtype != SVt_PVGV) {
3184 char *name = GvNAME(sstr);
3185 STRLEN len = GvNAMELEN(sstr);
3186 sv_upgrade(dstr, SVt_PVGV);
3187 sv_magic(dstr, dstr, '*', Nullch, 0);
3188 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3189 GvNAME(dstr) = savepvn(name, len);
3190 GvNAMELEN(dstr) = len;
3191 SvFAKE_on(dstr); /* can coerce to non-glob */
3193 /* ahem, death to those who redefine active sort subs */
3194 else if (PL_curstackinfo->si_type == PERLSI_SORT
3195 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3196 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3198 (void)SvOK_off(dstr);
3199 GvINTRO_off(dstr); /* one-shot flag */
3201 GvGP(dstr) = gp_ref(GvGP(sstr));
3202 if (SvTAINTED(sstr))
3204 if (GvIMPORTED(dstr) != GVf_IMPORTED
3205 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3207 GvIMPORTED_on(dstr);
3215 if (SvGMAGICAL(sstr)) {
3217 if (SvTYPE(sstr) != stype) {
3218 stype = SvTYPE(sstr);
3219 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3223 if (stype == SVt_PVLV)
3224 (void)SvUPGRADE(dstr, SVt_PVNV);
3226 (void)SvUPGRADE(dstr, stype);
3229 sflags = SvFLAGS(sstr);
3231 if (sflags & SVf_ROK) {
3232 if (dtype >= SVt_PV) {
3233 if (dtype == SVt_PVGV) {
3234 SV *sref = SvREFCNT_inc(SvRV(sstr));
3236 int intro = GvINTRO(dstr);
3241 GvINTRO_off(dstr); /* one-shot flag */
3242 Newz(602,gp, 1, GP);
3243 GvGP(dstr) = gp_ref(gp);
3244 GvSV(dstr) = NEWSV(72,0);
3245 GvLINE(dstr) = CopLINE(PL_curcop);
3246 GvEGV(dstr) = (GV*)dstr;
3249 switch (SvTYPE(sref)) {
3252 SAVESPTR(GvAV(dstr));
3254 dref = (SV*)GvAV(dstr);
3255 GvAV(dstr) = (AV*)sref;
3256 if (!GvIMPORTED_AV(dstr)
3257 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3259 GvIMPORTED_AV_on(dstr);
3264 SAVESPTR(GvHV(dstr));
3266 dref = (SV*)GvHV(dstr);
3267 GvHV(dstr) = (HV*)sref;
3268 if (!GvIMPORTED_HV(dstr)
3269 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3271 GvIMPORTED_HV_on(dstr);
3276 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3277 SvREFCNT_dec(GvCV(dstr));
3278 GvCV(dstr) = Nullcv;
3279 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3280 PL_sub_generation++;
3282 SAVESPTR(GvCV(dstr));
3285 dref = (SV*)GvCV(dstr);
3286 if (GvCV(dstr) != (CV*)sref) {
3287 CV* cv = GvCV(dstr);
3289 if (!GvCVGEN((GV*)dstr) &&
3290 (CvROOT(cv) || CvXSUB(cv)))
3293 /* ahem, death to those who redefine
3294 * active sort subs */
3295 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3296 PL_sortcop == CvSTART(cv))
3298 "Can't redefine active sort subroutine %s",
3299 GvENAME((GV*)dstr));
3300 /* Redefining a sub - warning is mandatory if
3301 it was a const and its value changed. */
3302 if (ckWARN(WARN_REDEFINE)
3304 && (!CvCONST((CV*)sref)
3305 || sv_cmp(cv_const_sv(cv),
3306 cv_const_sv((CV*)sref)))))
3308 Perl_warner(aTHX_ WARN_REDEFINE,
3310 ? "Constant subroutine %s redefined"
3311 : "Subroutine %s redefined",
3312 GvENAME((GV*)dstr));
3315 cv_ckproto(cv, (GV*)dstr,
3316 SvPOK(sref) ? SvPVX(sref) : Nullch);
3318 GvCV(dstr) = (CV*)sref;
3319 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3320 GvASSUMECV_on(dstr);
3321 PL_sub_generation++;
3323 if (!GvIMPORTED_CV(dstr)
3324 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3326 GvIMPORTED_CV_on(dstr);
3331 SAVESPTR(GvIOp(dstr));
3333 dref = (SV*)GvIOp(dstr);
3334 GvIOp(dstr) = (IO*)sref;
3338 SAVESPTR(GvFORM(dstr));
3340 dref = (SV*)GvFORM(dstr);
3341 GvFORM(dstr) = (CV*)sref;
3345 SAVESPTR(GvSV(dstr));
3347 dref = (SV*)GvSV(dstr);
3349 if (!GvIMPORTED_SV(dstr)
3350 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3352 GvIMPORTED_SV_on(dstr);
3360 if (SvTAINTED(sstr))
3365 (void)SvOOK_off(dstr); /* backoff */
3367 Safefree(SvPVX(dstr));
3368 SvLEN(dstr)=SvCUR(dstr)=0;
3371 (void)SvOK_off(dstr);
3372 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3374 if (sflags & SVp_NOK) {
3376 SvNVX(dstr) = SvNVX(sstr);
3378 if (sflags & SVp_IOK) {
3379 (void)SvIOK_on(dstr);
3380 SvIVX(dstr) = SvIVX(sstr);
3381 if (sflags & SVf_IVisUV)
3384 if (SvAMAGIC(sstr)) {
3388 else if (sflags & SVp_POK) {
3391 * Check to see if we can just swipe the string. If so, it's a
3392 * possible small lose on short strings, but a big win on long ones.
3393 * It might even be a win on short strings if SvPVX(dstr)
3394 * has to be allocated and SvPVX(sstr) has to be freed.
3397 if (SvTEMP(sstr) && /* slated for free anyway? */
3398 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3399 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3400 SvLEN(sstr) && /* and really is a string */
3401 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3403 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3405 SvFLAGS(dstr) &= ~SVf_OOK;
3406 Safefree(SvPVX(dstr) - SvIVX(dstr));
3408 else if (SvLEN(dstr))
3409 Safefree(SvPVX(dstr));
3411 (void)SvPOK_only(dstr);
3412 SvPV_set(dstr, SvPVX(sstr));
3413 SvLEN_set(dstr, SvLEN(sstr));
3414 SvCUR_set(dstr, SvCUR(sstr));
3417 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3418 SvPV_set(sstr, Nullch);
3423 else { /* have to copy actual string */
3424 STRLEN len = SvCUR(sstr);
3426 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3427 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3428 SvCUR_set(dstr, len);
3429 *SvEND(dstr) = '\0';
3430 (void)SvPOK_only(dstr);
3432 if ((sflags & SVf_UTF8) && !IN_BYTE)
3435 if (sflags & SVp_NOK) {
3437 SvNVX(dstr) = SvNVX(sstr);
3439 if (sflags & SVp_IOK) {
3440 (void)SvIOK_on(dstr);
3441 SvIVX(dstr) = SvIVX(sstr);
3442 if (sflags & SVf_IVisUV)
3446 else if (sflags & SVp_NOK) {
3447 SvNVX(dstr) = SvNVX(sstr);
3448 (void)SvNOK_only(dstr);
3449 if (sflags & SVf_IOK) {
3450 (void)SvIOK_on(dstr);
3451 SvIVX(dstr) = SvIVX(sstr);
3452 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3453 if (sflags & SVf_IVisUV)
3457 else if (sflags & SVp_IOK) {
3458 (void)SvIOK_only(dstr);
3459 SvIVX(dstr) = SvIVX(sstr);
3460 if (sflags & SVf_IVisUV)
3464 if (dtype == SVt_PVGV) {
3465 if (ckWARN(WARN_MISC))
3466 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3469 (void)SvOK_off(dstr);
3471 if (SvTAINTED(sstr))
3476 =for apidoc sv_setsv_mg
3478 Like C<sv_setsv>, but also handles 'set' magic.
3484 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3486 sv_setsv(dstr,sstr);
3491 =for apidoc sv_setpvn
3493 Copies a string into an SV. The C<len> parameter indicates the number of
3494 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3500 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3502 register char *dptr;
3504 /* len is STRLEN which is unsigned, need to copy to signed */
3508 SV_CHECK_THINKFIRST(sv);
3513 (void)SvUPGRADE(sv, SVt_PV);
3515 SvGROW(sv, len + 1);
3517 Move(ptr,dptr,len,char);
3520 (void)SvPOK_only(sv); /* validate pointer */
3525 =for apidoc sv_setpvn_mg
3527 Like C<sv_setpvn>, but also handles 'set' magic.
3533 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3535 sv_setpvn(sv,ptr,len);
3540 =for apidoc sv_setpv
3542 Copies a string into an SV. The string must be null-terminated. Does not
3543 handle 'set' magic. See C<sv_setpv_mg>.
3549 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3551 register STRLEN len;
3553 SV_CHECK_THINKFIRST(sv);
3559 (void)SvUPGRADE(sv, SVt_PV);
3561 SvGROW(sv, len + 1);
3562 Move(ptr,SvPVX(sv),len+1,char);
3564 (void)SvPOK_only(sv); /* validate pointer */
3569 =for apidoc sv_setpv_mg
3571 Like C<sv_setpv>, but also handles 'set' magic.
3577 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3584 =for apidoc sv_usepvn
3586 Tells an SV to use C<ptr> to find its string value. Normally the string is
3587 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3588 The C<ptr> should point to memory that was allocated by C<malloc>. The
3589 string length, C<len>, must be supplied. This function will realloc the
3590 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3591 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3592 See C<sv_usepvn_mg>.
3598 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3600 SV_CHECK_THINKFIRST(sv);
3601 (void)SvUPGRADE(sv, SVt_PV);
3606 (void)SvOOK_off(sv);
3607 if (SvPVX(sv) && SvLEN(sv))
3608 Safefree(SvPVX(sv));
3609 Renew(ptr, len+1, char);
3612 SvLEN_set(sv, len+1);
3614 (void)SvPOK_only(sv); /* validate pointer */
3619 =for apidoc sv_usepvn_mg
3621 Like C<sv_usepvn>, but also handles 'set' magic.
3627 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3629 sv_usepvn(sv,ptr,len);
3634 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3636 if (SvREADONLY(sv)) {
3638 char *pvx = SvPVX(sv);
3639 STRLEN len = SvCUR(sv);
3640 U32 hash = SvUVX(sv);
3641 SvGROW(sv, len + 1);
3642 Move(pvx,SvPVX(sv),len,char);
3646 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3648 else if (PL_curcop != &PL_compiling)
3649 Perl_croak(aTHX_ PL_no_modify);
3652 sv_unref_flags(sv, flags);
3653 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3658 Perl_sv_force_normal(pTHX_ register SV *sv)
3660 sv_force_normal_flags(sv, 0);
3666 Efficient removal of characters from the beginning of the string buffer.
3667 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3668 the string buffer. The C<ptr> becomes the first character of the adjusted
3675 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3679 register STRLEN delta;
3681 if (!ptr || !SvPOKp(sv))
3683 SV_CHECK_THINKFIRST(sv);
3684 if (SvTYPE(sv) < SVt_PVIV)
3685 sv_upgrade(sv,SVt_PVIV);
3688 if (!SvLEN(sv)) { /* make copy of shared string */
3689 char *pvx = SvPVX(sv);
3690 STRLEN len = SvCUR(sv);
3691 SvGROW(sv, len + 1);
3692 Move(pvx,SvPVX(sv),len,char);
3696 SvFLAGS(sv) |= SVf_OOK;
3698 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3699 delta = ptr - SvPVX(sv);
3707 =for apidoc sv_catpvn
3709 Concatenates the string onto the end of the string which is in the SV. The
3710 C<len> indicates number of bytes to copy. Handles 'get' magic, but not
3711 'set' magic. See C<sv_catpvn_mg>.
3717 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3722 junk = SvPV_force(sv, tlen);
3723 SvGROW(sv, tlen + len + 1);
3726 Move(ptr,SvPVX(sv)+tlen,len,char);
3729 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3734 =for apidoc sv_catpvn_mg
3736 Like C<sv_catpvn>, but also handles 'set' magic.
3742 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3744 sv_catpvn(sv,ptr,len);
3749 =for apidoc sv_catsv
3751 Concatenates the string from SV C<ssv> onto the end of the string in SV
3752 C<dsv>. Handles 'get' magic, but not 'set' magic. See C<sv_catsv_mg>.
3758 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3766 if ((spv = SvPV(ssv, slen))) {
3767 bool dutf8 = DO_UTF8(dsv);
3768 bool sutf8 = DO_UTF8(ssv);
3770 if (dutf8 != sutf8) {
3774 /* We may modify dsv but not ssv. */
3777 sv_utf8_upgrade(dsv);
3778 dpv = SvPV(dsv, dlen);
3779 /* Overguestimate on the slen. */
3780 SvGROW(dsv, dlen + (sutf8 ? 2 * slen : slen) + 1);
3781 if (dutf8) /* && !sutf8 */ {
3784 char *d = dpv + dlen;
3790 if (UTF8_IS_ASCII(c))
3793 *d++ = UTF8_EIGHT_BIT_HI(c);
3794 *d++ = UTF8_EIGHT_BIT_LO(c);
3797 SvCUR(dsv) += d - dorig;
3800 else /* !dutf8 (was) && sutf8 */ {
3801 sv_catpvn(dsv, spv, slen);
3806 sv_catpvn(dsv, spv, slen);
3812 =for apidoc sv_catsv_mg
3814 Like C<sv_catsv>, but also handles 'set' magic.
3820 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3827 =for apidoc sv_catpv
3829 Concatenates the string onto the end of the string which is in the SV.
3830 Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3836 Perl_sv_catpv(pTHX_ register SV *sv, register const char *pv)
3838 register STRLEN len;
3844 junk = SvPV_force(sv, tlen);
3846 SvGROW(sv, tlen + len + 1);
3849 Move(pv,SvPVX(sv)+tlen,len+1,char);
3851 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3856 =for apidoc sv_catpv_mg
3858 Like C<sv_catpv>, but also handles 'set' magic.
3864 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *pv)
3871 Perl_newSV(pTHX_ STRLEN len)
3877 sv_upgrade(sv, SVt_PV);
3878 SvGROW(sv, len + 1);
3883 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3886 =for apidoc sv_magic
3888 Adds magic to an SV.
3894 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3898 if (SvREADONLY(sv)) {
3899 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3900 Perl_croak(aTHX_ PL_no_modify);
3902 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3903 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
3910 (void)SvUPGRADE(sv, SVt_PVMG);
3912 Newz(702,mg, 1, MAGIC);
3913 mg->mg_moremagic = SvMAGIC(sv);
3916 if (!obj || obj == sv || how == '#' || how == 'r')
3919 mg->mg_obj = SvREFCNT_inc(obj);
3920 mg->mg_flags |= MGf_REFCOUNTED;
3923 mg->mg_len = namlen;
3926 mg->mg_ptr = savepvn(name, namlen);
3927 else if (namlen == HEf_SVKEY)
3928 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
3932 mg->mg_virtual = &PL_vtbl_sv;
3935 mg->mg_virtual = &PL_vtbl_amagic;
3938 mg->mg_virtual = &PL_vtbl_amagicelem;
3944 mg->mg_virtual = &PL_vtbl_bm;
3947 mg->mg_virtual = &PL_vtbl_regdata;
3950 mg->mg_virtual = &PL_vtbl_regdatum;
3953 mg->mg_virtual = &PL_vtbl_env;
3956 mg->mg_virtual = &PL_vtbl_fm;
3959 mg->mg_virtual = &PL_vtbl_envelem;
3962 mg->mg_virtual = &PL_vtbl_mglob;
3965 mg->mg_virtual = &PL_vtbl_isa;
3968 mg->mg_virtual = &PL_vtbl_isaelem;
3971 mg->mg_virtual = &PL_vtbl_nkeys;
3978 mg->mg_virtual = &PL_vtbl_dbline;
3982 mg->mg_virtual = &PL_vtbl_mutex;
3984 #endif /* USE_THREADS */
3985 #ifdef USE_LOCALE_COLLATE
3987 mg->mg_virtual = &PL_vtbl_collxfrm;
3989 #endif /* USE_LOCALE_COLLATE */
3991 mg->mg_virtual = &PL_vtbl_pack;
3995 mg->mg_virtual = &PL_vtbl_packelem;
3998 mg->mg_virtual = &PL_vtbl_regexp;
4001 mg->mg_virtual = &PL_vtbl_sig;
4004 mg->mg_virtual = &PL_vtbl_sigelem;
4007 mg->mg_virtual = &PL_vtbl_taint;
4011 mg->mg_virtual = &PL_vtbl_uvar;
4014 mg->mg_virtual = &PL_vtbl_vec;
4017 mg->mg_virtual = &PL_vtbl_substr;
4020 mg->mg_virtual = &PL_vtbl_defelem;
4023 mg->mg_virtual = &PL_vtbl_glob;
4026 mg->mg_virtual = &PL_vtbl_arylen;
4029 mg->mg_virtual = &PL_vtbl_pos;
4032 mg->mg_virtual = &PL_vtbl_backref;
4034 case '~': /* Reserved for use by extensions not perl internals. */
4035 /* Useful for attaching extension internal data to perl vars. */
4036 /* Note that multiple extensions may clash if magical scalars */
4037 /* etc holding private data from one are passed to another. */
4041 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4045 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4049 =for apidoc sv_unmagic
4051 Removes magic from an SV.
4057 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4061 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4064 for (mg = *mgp; mg; mg = *mgp) {
4065 if (mg->mg_type == type) {
4066 MGVTBL* vtbl = mg->mg_virtual;
4067 *mgp = mg->mg_moremagic;
4068 if (vtbl && vtbl->svt_free)
4069 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4070 if (mg->mg_ptr && mg->mg_type != 'g')
4071 if (mg->mg_len >= 0)
4072 Safefree(mg->mg_ptr);
4073 else if (mg->mg_len == HEf_SVKEY)
4074 SvREFCNT_dec((SV*)mg->mg_ptr);
4075 if (mg->mg_flags & MGf_REFCOUNTED)
4076 SvREFCNT_dec(mg->mg_obj);
4080 mgp = &mg->mg_moremagic;
4084 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4091 =for apidoc sv_rvweaken
4099 Perl_sv_rvweaken(pTHX_ SV *sv)
4102 if (!SvOK(sv)) /* let undefs pass */
4105 Perl_croak(aTHX_ "Can't weaken a nonreference");
4106 else if (SvWEAKREF(sv)) {
4107 if (ckWARN(WARN_MISC))
4108 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4112 sv_add_backref(tsv, sv);
4119 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4123 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4124 av = (AV*)mg->mg_obj;
4127 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4128 SvREFCNT_dec(av); /* for sv_magic */
4134 S_sv_del_backref(pTHX_ SV *sv)
4141 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4142 Perl_croak(aTHX_ "panic: del_backref");
4143 av = (AV *)mg->mg_obj;
4148 svp[i] = &PL_sv_undef; /* XXX */
4155 =for apidoc sv_insert
4157 Inserts a string at the specified offset/length within the SV. Similar to
4158 the Perl substr() function.
4164 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4168 register char *midend;
4169 register char *bigend;
4175 Perl_croak(aTHX_ "Can't modify non-existent substring");
4176 SvPV_force(bigstr, curlen);
4177 (void)SvPOK_only_UTF8(bigstr);
4178 if (offset + len > curlen) {
4179 SvGROW(bigstr, offset+len+1);
4180 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4181 SvCUR_set(bigstr, offset+len);
4185 i = littlelen - len;
4186 if (i > 0) { /* string might grow */
4187 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4188 mid = big + offset + len;
4189 midend = bigend = big + SvCUR(bigstr);
4192 while (midend > mid) /* shove everything down */
4193 *--bigend = *--midend;
4194 Move(little,big+offset,littlelen,char);
4200 Move(little,SvPVX(bigstr)+offset,len,char);
4205 big = SvPVX(bigstr);
4208 bigend = big + SvCUR(bigstr);
4210 if (midend > bigend)
4211 Perl_croak(aTHX_ "panic: sv_insert");
4213 if (mid - big > bigend - midend) { /* faster to shorten from end */
4215 Move(little, mid, littlelen,char);
4218 i = bigend - midend;
4220 Move(midend, mid, i,char);
4224 SvCUR_set(bigstr, mid - big);
4227 else if ((i = mid - big)) { /* faster from front */
4228 midend -= littlelen;
4230 sv_chop(bigstr,midend-i);
4235 Move(little, mid, littlelen,char);
4237 else if (littlelen) {
4238 midend -= littlelen;
4239 sv_chop(bigstr,midend);
4240 Move(little,midend,littlelen,char);
4243 sv_chop(bigstr,midend);
4249 =for apidoc sv_replace
4251 Make the first argument a copy of the second, then delete the original.
4257 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4259 U32 refcnt = SvREFCNT(sv);
4260 SV_CHECK_THINKFIRST(sv);
4261 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4262 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4263 if (SvMAGICAL(sv)) {
4267 sv_upgrade(nsv, SVt_PVMG);
4268 SvMAGIC(nsv) = SvMAGIC(sv);
4269 SvFLAGS(nsv) |= SvMAGICAL(sv);
4275 assert(!SvREFCNT(sv));
4276 StructCopy(nsv,sv,SV);
4277 SvREFCNT(sv) = refcnt;
4278 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4283 =for apidoc sv_clear
4285 Clear an SV, making it empty. Does not free the memory used by the SV
4292 Perl_sv_clear(pTHX_ register SV *sv)
4296 assert(SvREFCNT(sv) == 0);
4299 if (PL_defstash) { /* Still have a symbol table? */
4304 Zero(&tmpref, 1, SV);
4305 sv_upgrade(&tmpref, SVt_RV);
4307 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4308 SvREFCNT(&tmpref) = 1;
4311 stash = SvSTASH(sv);
4312 destructor = StashHANDLER(stash,DESTROY);
4315 PUSHSTACKi(PERLSI_DESTROY);
4316 SvRV(&tmpref) = SvREFCNT_inc(sv);
4321 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4327 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4329 del_XRV(SvANY(&tmpref));
4332 if (PL_in_clean_objs)
4333 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4335 /* DESTROY gave object new lease on life */
4341 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4342 SvOBJECT_off(sv); /* Curse the object. */
4343 if (SvTYPE(sv) != SVt_PVIO)
4344 --PL_sv_objcount; /* XXX Might want something more general */
4347 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4350 switch (SvTYPE(sv)) {
4353 IoIFP(sv) != PerlIO_stdin() &&
4354 IoIFP(sv) != PerlIO_stdout() &&
4355 IoIFP(sv) != PerlIO_stderr())
4357 io_close((IO*)sv, FALSE);
4359 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4360 PerlDir_close(IoDIRP(sv));
4361 IoDIRP(sv) = (DIR*)NULL;
4362 Safefree(IoTOP_NAME(sv));
4363 Safefree(IoFMT_NAME(sv));
4364 Safefree(IoBOTTOM_NAME(sv));
4379 SvREFCNT_dec(LvTARG(sv));
4383 Safefree(GvNAME(sv));
4384 /* cannot decrease stash refcount yet, as we might recursively delete
4385 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4386 of stash until current sv is completely gone.
4387 -- JohnPC, 27 Mar 1998 */
4388 stash = GvSTASH(sv);
4394 (void)SvOOK_off(sv);
4402 SvREFCNT_dec(SvRV(sv));
4404 else if (SvPVX(sv) && SvLEN(sv))
4405 Safefree(SvPVX(sv));
4406 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4407 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4419 switch (SvTYPE(sv)) {
4435 del_XPVIV(SvANY(sv));
4438 del_XPVNV(SvANY(sv));
4441 del_XPVMG(SvANY(sv));
4444 del_XPVLV(SvANY(sv));
4447 del_XPVAV(SvANY(sv));
4450 del_XPVHV(SvANY(sv));
4453 del_XPVCV(SvANY(sv));
4456 del_XPVGV(SvANY(sv));
4457 /* code duplication for increased performance. */
4458 SvFLAGS(sv) &= SVf_BREAK;
4459 SvFLAGS(sv) |= SVTYPEMASK;
4460 /* decrease refcount of the stash that owns this GV, if any */
4462 SvREFCNT_dec(stash);
4463 return; /* not break, SvFLAGS reset already happened */
4465 del_XPVBM(SvANY(sv));
4468 del_XPVFM(SvANY(sv));
4471 del_XPVIO(SvANY(sv));
4474 SvFLAGS(sv) &= SVf_BREAK;
4475 SvFLAGS(sv) |= SVTYPEMASK;
4479 Perl_sv_newref(pTHX_ SV *sv)
4482 ATOMIC_INC(SvREFCNT(sv));
4489 Free the memory used by an SV.
4495 Perl_sv_free(pTHX_ SV *sv)
4497 int refcount_is_zero;
4501 if (SvREFCNT(sv) == 0) {
4502 if (SvFLAGS(sv) & SVf_BREAK)
4504 if (PL_in_clean_all) /* All is fair */
4506 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4507 /* make sure SvREFCNT(sv)==0 happens very seldom */
4508 SvREFCNT(sv) = (~(U32)0)/2;
4511 if (ckWARN_d(WARN_INTERNAL))
4512 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4515 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4516 if (!refcount_is_zero)
4520 if (ckWARN_d(WARN_DEBUGGING))
4521 Perl_warner(aTHX_ WARN_DEBUGGING,
4522 "Attempt to free temp prematurely: SV 0x%"UVxf,
4527 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4528 /* make sure SvREFCNT(sv)==0 happens very seldom */
4529 SvREFCNT(sv) = (~(U32)0)/2;
4540 Returns the length of the string in the SV. See also C<SvCUR>.
4546 Perl_sv_len(pTHX_ register SV *sv)
4555 len = mg_length(sv);
4557 junk = SvPV(sv, len);
4562 =for apidoc sv_len_utf8
4564 Returns the number of characters in the string in an SV, counting wide
4565 UTF8 bytes as a single character.
4571 Perl_sv_len_utf8(pTHX_ register SV *sv)
4577 return mg_length(sv);
4581 U8 *s = (U8*)SvPV(sv, len);
4583 return Perl_utf8_length(aTHX_ s, s + len);
4588 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4593 I32 uoffset = *offsetp;
4599 start = s = (U8*)SvPV(sv, len);
4601 while (s < send && uoffset--)
4605 *offsetp = s - start;
4609 while (s < send && ulen--)
4619 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4628 s = (U8*)SvPV(sv, len);
4630 Perl_croak(aTHX_ "panic: bad byte offset");
4631 send = s + *offsetp;
4638 if (ckWARN_d(WARN_UTF8))
4639 Perl_warner(aTHX_ WARN_UTF8, "Malformed UTF-8 character");
4649 Returns a boolean indicating whether the strings in the two SVs are
4656 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4663 bool pv1tmp = FALSE;
4664 bool pv2tmp = FALSE;
4671 pv1 = SvPV(sv1, cur1);
4678 pv2 = SvPV(sv2, cur2);
4680 /* do not utf8ize the comparands as a side-effect */
4681 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4683 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4687 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4693 eq = memEQ(pv1, pv2, cur1);
4706 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4707 string in C<sv1> is less than, equal to, or greater than the string in
4714 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4719 bool pv1tmp = FALSE;
4720 bool pv2tmp = FALSE;
4727 pv1 = SvPV(sv1, cur1);
4734 pv2 = SvPV(sv2, cur2);
4736 /* do not utf8ize the comparands as a side-effect */
4737 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4739 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4743 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4749 cmp = cur2 ? -1 : 0;
4753 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4756 cmp = retval < 0 ? -1 : 1;
4757 } else if (cur1 == cur2) {
4760 cmp = cur1 < cur2 ? -1 : 1;
4773 =for apidoc sv_cmp_locale
4775 Compares the strings in two SVs in a locale-aware manner. See
4782 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4784 #ifdef USE_LOCALE_COLLATE
4790 if (PL_collation_standard)
4794 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4796 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4798 if (!pv1 || !len1) {
4809 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4812 return retval < 0 ? -1 : 1;
4815 * When the result of collation is equality, that doesn't mean
4816 * that there are no differences -- some locales exclude some
4817 * characters from consideration. So to avoid false equalities,
4818 * we use the raw string as a tiebreaker.
4824 #endif /* USE_LOCALE_COLLATE */
4826 return sv_cmp(sv1, sv2);
4829 #ifdef USE_LOCALE_COLLATE
4831 * Any scalar variable may carry an 'o' magic that contains the
4832 * scalar data of the variable transformed to such a format that
4833 * a normal memory comparison can be used to compare the data
4834 * according to the locale settings.
4837 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4841 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4842 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4847 Safefree(mg->mg_ptr);
4849 if ((xf = mem_collxfrm(s, len, &xlen))) {
4850 if (SvREADONLY(sv)) {
4853 return xf + sizeof(PL_collation_ix);
4856 sv_magic(sv, 0, 'o', 0, 0);
4857 mg = mg_find(sv, 'o');
4870 if (mg && mg->mg_ptr) {
4872 return mg->mg_ptr + sizeof(PL_collation_ix);
4880 #endif /* USE_LOCALE_COLLATE */
4885 Get a line from the filehandle and store it into the SV, optionally
4886 appending to the currently-stored string.
4892 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
4896 register STDCHAR rslast;
4897 register STDCHAR *bp;
4901 SV_CHECK_THINKFIRST(sv);
4902 (void)SvUPGRADE(sv, SVt_PV);
4906 if (RsSNARF(PL_rs)) {
4910 else if (RsRECORD(PL_rs)) {
4911 I32 recsize, bytesread;
4914 /* Grab the size of the record we're getting */
4915 recsize = SvIV(SvRV(PL_rs));
4916 (void)SvPOK_only(sv); /* Validate pointer */
4917 buffer = SvGROW(sv, recsize + 1);
4920 /* VMS wants read instead of fread, because fread doesn't respect */
4921 /* RMS record boundaries. This is not necessarily a good thing to be */
4922 /* doing, but we've got no other real choice */
4923 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
4925 bytesread = PerlIO_read(fp, buffer, recsize);
4927 SvCUR_set(sv, bytesread);
4928 buffer[bytesread] = '\0';
4929 if (PerlIO_isutf8(fp))
4933 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
4935 else if (RsPARA(PL_rs)) {
4940 /* Get $/ i.e. PL_rs into same encoding as stream wants */
4941 if (PerlIO_isutf8(fp)) {
4942 rsptr = SvPVutf8(PL_rs, rslen);
4945 if (SvUTF8(PL_rs)) {
4946 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
4947 Perl_croak(aTHX_ "Wide character in $/");
4950 rsptr = SvPV(PL_rs, rslen);
4954 rslast = rslen ? rsptr[rslen - 1] : '\0';
4956 if (RsPARA(PL_rs)) { /* have to do this both before and after */
4957 do { /* to make sure file boundaries work right */
4960 i = PerlIO_getc(fp);
4964 PerlIO_ungetc(fp,i);
4970 /* See if we know enough about I/O mechanism to cheat it ! */
4972 /* This used to be #ifdef test - it is made run-time test for ease
4973 of abstracting out stdio interface. One call should be cheap
4974 enough here - and may even be a macro allowing compile
4978 if (PerlIO_fast_gets(fp)) {
4981 * We're going to steal some values from the stdio struct
4982 * and put EVERYTHING in the innermost loop into registers.
4984 register STDCHAR *ptr;
4988 #if defined(VMS) && defined(PERLIO_IS_STDIO)
4989 /* An ungetc()d char is handled separately from the regular
4990 * buffer, so we getc() it back out and stuff it in the buffer.
4992 i = PerlIO_getc(fp);
4993 if (i == EOF) return 0;
4994 *(--((*fp)->_ptr)) = (unsigned char) i;
4998 /* Here is some breathtakingly efficient cheating */
5000 cnt = PerlIO_get_cnt(fp); /* get count into register */
5001 (void)SvPOK_only(sv); /* validate pointer */
5002 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5003 if (cnt > 80 && SvLEN(sv) > append) {
5004 shortbuffered = cnt - SvLEN(sv) + append + 1;
5005 cnt -= shortbuffered;
5009 /* remember that cnt can be negative */
5010 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5015 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5016 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5017 DEBUG_P(PerlIO_printf(Perl_debug_log,
5018 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5019 DEBUG_P(PerlIO_printf(Perl_debug_log,
5020 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5021 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5022 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5027 while (cnt > 0) { /* this | eat */
5029 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5030 goto thats_all_folks; /* screams | sed :-) */
5034 Copy(ptr, bp, cnt, char); /* this | eat */
5035 bp += cnt; /* screams | dust */
5036 ptr += cnt; /* louder | sed :-) */
5041 if (shortbuffered) { /* oh well, must extend */
5042 cnt = shortbuffered;
5044 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5046 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5047 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5051 DEBUG_P(PerlIO_printf(Perl_debug_log,
5052 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5053 PTR2UV(ptr),(long)cnt));
5054 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5055 DEBUG_P(PerlIO_printf(Perl_debug_log,
5056 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5057 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5058 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5059 /* This used to call 'filbuf' in stdio form, but as that behaves like
5060 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5061 another abstraction. */
5062 i = PerlIO_getc(fp); /* get more characters */
5063 DEBUG_P(PerlIO_printf(Perl_debug_log,
5064 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5065 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5066 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5067 cnt = PerlIO_get_cnt(fp);
5068 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5069 DEBUG_P(PerlIO_printf(Perl_debug_log,
5070 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5072 if (i == EOF) /* all done for ever? */
5073 goto thats_really_all_folks;
5075 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5077 SvGROW(sv, bpx + cnt + 2);
5078 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5080 *bp++ = i; /* store character from PerlIO_getc */
5082 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5083 goto thats_all_folks;
5087 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5088 memNE((char*)bp - rslen, rsptr, rslen))
5089 goto screamer; /* go back to the fray */
5090 thats_really_all_folks:
5092 cnt += shortbuffered;
5093 DEBUG_P(PerlIO_printf(Perl_debug_log,
5094 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5095 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5096 DEBUG_P(PerlIO_printf(Perl_debug_log,
5097 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5098 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5099 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5101 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5102 DEBUG_P(PerlIO_printf(Perl_debug_log,
5103 "Screamer: done, len=%ld, string=|%.*s|\n",
5104 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5109 /*The big, slow, and stupid way */
5112 /* Need to work around EPOC SDK features */
5113 /* On WINS: MS VC5 generates calls to _chkstk, */
5114 /* if a `large' stack frame is allocated */
5115 /* gcc on MARM does not generate calls like these */
5121 register STDCHAR *bpe = buf + sizeof(buf);
5123 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5124 ; /* keep reading */
5128 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5129 /* Accomodate broken VAXC compiler, which applies U8 cast to
5130 * both args of ?: operator, causing EOF to change into 255
5132 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5136 sv_catpvn(sv, (char *) buf, cnt);
5138 sv_setpvn(sv, (char *) buf, cnt);
5140 if (i != EOF && /* joy */
5142 SvCUR(sv) < rslen ||
5143 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5147 * If we're reading from a TTY and we get a short read,
5148 * indicating that the user hit his EOF character, we need
5149 * to notice it now, because if we try to read from the TTY
5150 * again, the EOF condition will disappear.
5152 * The comparison of cnt to sizeof(buf) is an optimization
5153 * that prevents unnecessary calls to feof().
5157 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5162 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5163 while (i != EOF) { /* to make sure file boundaries work right */
5164 i = PerlIO_getc(fp);
5166 PerlIO_ungetc(fp,i);
5172 if (PerlIO_isutf8(fp))
5177 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5184 Auto-increment of the value in the SV.
5190 Perl_sv_inc(pTHX_ register SV *sv)
5199 if (SvTHINKFIRST(sv)) {
5200 if (SvREADONLY(sv)) {
5201 if (PL_curcop != &PL_compiling)
5202 Perl_croak(aTHX_ PL_no_modify);
5206 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5208 i = PTR2IV(SvRV(sv));
5213 flags = SvFLAGS(sv);
5214 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5215 /* It's (privately or publicly) a float, but not tested as an
5216 integer, so test it to see. */
5218 flags = SvFLAGS(sv);
5220 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5221 /* It's publicly an integer, or privately an integer-not-float */
5224 if (SvUVX(sv) == UV_MAX)
5225 sv_setnv(sv, (NV)UV_MAX + 1.0);
5227 (void)SvIOK_only_UV(sv);
5230 if (SvIVX(sv) == IV_MAX)
5231 sv_setuv(sv, (UV)IV_MAX + 1);
5233 (void)SvIOK_only(sv);
5239 if (flags & SVp_NOK) {
5240 (void)SvNOK_only(sv);
5245 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5246 if ((flags & SVTYPEMASK) < SVt_PVIV)
5247 sv_upgrade(sv, SVt_IV);
5248 (void)SvIOK_only(sv);
5253 while (isALPHA(*d)) d++;
5254 while (isDIGIT(*d)) d++;
5256 #ifdef PERL_PRESERVE_IVUV
5257 /* Got to punt this an an integer if needs be, but we don't issue
5258 warnings. Probably ought to make the sv_iv_please() that does
5259 the conversion if possible, and silently. */
5260 I32 numtype = looks_like_number(sv);
5261 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5262 /* Need to try really hard to see if it's an integer.
5263 9.22337203685478e+18 is an integer.
5264 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5265 so $a="9.22337203685478e+18"; $a+0; $a++
5266 needs to be the same as $a="9.22337203685478e+18"; $a++
5273 /* sv_2iv *should* have made this an NV */
5274 if (flags & SVp_NOK) {
5275 (void)SvNOK_only(sv);
5279 /* I don't think we can get here. Maybe I should assert this
5280 And if we do get here I suspect that sv_setnv will croak. NWC
5282 #if defined(USE_LONG_DOUBLE)
5283 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",
5284 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5286 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5287 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5290 #endif /* PERL_PRESERVE_IVUV */
5291 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5295 while (d >= SvPVX(sv)) {
5303 /* MKS: The original code here died if letters weren't consecutive.
5304 * at least it didn't have to worry about non-C locales. The
5305 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5306 * arranged in order (although not consecutively) and that only
5307 * [A-Za-z] are accepted by isALPHA in the C locale.
5309 if (*d != 'z' && *d != 'Z') {
5310 do { ++*d; } while (!isALPHA(*d));
5313 *(d--) -= 'z' - 'a';
5318 *(d--) -= 'z' - 'a' + 1;
5322 /* oh,oh, the number grew */
5323 SvGROW(sv, SvCUR(sv) + 2);
5325 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5336 Auto-decrement of the value in the SV.
5342 Perl_sv_dec(pTHX_ register SV *sv)
5350 if (SvTHINKFIRST(sv)) {
5351 if (SvREADONLY(sv)) {
5352 if (PL_curcop != &PL_compiling)
5353 Perl_croak(aTHX_ PL_no_modify);
5357 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5359 i = PTR2IV(SvRV(sv));
5364 /* Unlike sv_inc we don't have to worry about string-never-numbers
5365 and keeping them magic. But we mustn't warn on punting */
5366 flags = SvFLAGS(sv);
5367 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5368 /* It's publicly an integer, or privately an integer-not-float */
5371 if (SvUVX(sv) == 0) {
5372 (void)SvIOK_only(sv);
5376 (void)SvIOK_only_UV(sv);
5380 if (SvIVX(sv) == IV_MIN)
5381 sv_setnv(sv, (NV)IV_MIN - 1.0);
5383 (void)SvIOK_only(sv);
5389 if (flags & SVp_NOK) {
5391 (void)SvNOK_only(sv);
5394 if (!(flags & SVp_POK)) {
5395 if ((flags & SVTYPEMASK) < SVt_PVNV)
5396 sv_upgrade(sv, SVt_NV);
5398 (void)SvNOK_only(sv);
5401 #ifdef PERL_PRESERVE_IVUV
5403 I32 numtype = looks_like_number(sv);
5404 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5405 /* Need to try really hard to see if it's an integer.
5406 9.22337203685478e+18 is an integer.
5407 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5408 so $a="9.22337203685478e+18"; $a+0; $a--
5409 needs to be the same as $a="9.22337203685478e+18"; $a--
5416 /* sv_2iv *should* have made this an NV */
5417 if (flags & SVp_NOK) {
5418 (void)SvNOK_only(sv);
5422 /* I don't think we can get here. Maybe I should assert this
5423 And if we do get here I suspect that sv_setnv will croak. NWC
5425 #if defined(USE_LONG_DOUBLE)
5426 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",
5427 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5429 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5430 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5434 #endif /* PERL_PRESERVE_IVUV */
5435 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5439 =for apidoc sv_mortalcopy
5441 Creates a new SV which is a copy of the original SV. The new SV is marked
5447 /* Make a string that will exist for the duration of the expression
5448 * evaluation. Actually, it may have to last longer than that, but
5449 * hopefully we won't free it until it has been assigned to a
5450 * permanent location. */
5453 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5458 sv_setsv(sv,oldstr);
5460 PL_tmps_stack[++PL_tmps_ix] = sv;
5466 =for apidoc sv_newmortal
5468 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5474 Perl_sv_newmortal(pTHX)
5479 SvFLAGS(sv) = SVs_TEMP;
5481 PL_tmps_stack[++PL_tmps_ix] = sv;
5486 =for apidoc sv_2mortal
5488 Marks an SV as mortal. The SV will be destroyed when the current context
5494 /* same thing without the copying */
5497 Perl_sv_2mortal(pTHX_ register SV *sv)
5501 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5504 PL_tmps_stack[++PL_tmps_ix] = sv;
5512 Creates a new SV and copies a string into it. The reference count for the
5513 SV is set to 1. If C<len> is zero, Perl will compute the length using
5514 strlen(). For efficiency, consider using C<newSVpvn> instead.
5520 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5527 sv_setpvn(sv,s,len);
5532 =for apidoc newSVpvn
5534 Creates a new SV and copies a string into it. The reference count for the
5535 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5536 string. You are responsible for ensuring that the source string is at least
5543 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5548 sv_setpvn(sv,s,len);
5553 =for apidoc newSVpvn_share
5555 Creates a new SV and populates it with a string from
5556 the string table. Turns on READONLY and FAKE.
5557 The idea here is that as string table is used for shared hash
5558 keys these strings will have SvPVX == HeKEY and hash lookup
5559 will avoid string compare.
5565 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5568 bool is_utf8 = FALSE;
5574 PERL_HASH(hash, src, len);
5576 sv_upgrade(sv, SVt_PVIV);
5577 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5589 #if defined(PERL_IMPLICIT_CONTEXT)
5591 Perl_newSVpvf_nocontext(const char* pat, ...)
5596 va_start(args, pat);
5597 sv = vnewSVpvf(pat, &args);
5604 =for apidoc newSVpvf
5606 Creates a new SV an initialize it with the string formatted like
5613 Perl_newSVpvf(pTHX_ const char* pat, ...)
5617 va_start(args, pat);
5618 sv = vnewSVpvf(pat, &args);
5624 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5628 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5635 Creates a new SV and copies a floating point value into it.
5636 The reference count for the SV is set to 1.
5642 Perl_newSVnv(pTHX_ NV n)
5654 Creates a new SV and copies an integer into it. The reference count for the
5661 Perl_newSViv(pTHX_ IV i)
5673 Creates a new SV and copies an unsigned integer into it.
5674 The reference count for the SV is set to 1.
5680 Perl_newSVuv(pTHX_ UV u)
5690 =for apidoc newRV_noinc
5692 Creates an RV wrapper for an SV. The reference count for the original
5693 SV is B<not> incremented.
5699 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5704 sv_upgrade(sv, SVt_RV);
5711 /* newRV_inc is #defined to newRV in sv.h */
5713 Perl_newRV(pTHX_ SV *tmpRef)
5715 return newRV_noinc(SvREFCNT_inc(tmpRef));
5721 Creates a new SV which is an exact duplicate of the original SV.
5726 /* make an exact duplicate of old */
5729 Perl_newSVsv(pTHX_ register SV *old)
5735 if (SvTYPE(old) == SVTYPEMASK) {
5736 if (ckWARN_d(WARN_INTERNAL))
5737 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5752 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5760 char todo[PERL_UCHAR_MAX+1];
5765 if (!*s) { /* reset ?? searches */
5766 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5767 pm->op_pmdynflags &= ~PMdf_USED;
5772 /* reset variables */
5774 if (!HvARRAY(stash))
5777 Zero(todo, 256, char);
5779 i = (unsigned char)*s;
5783 max = (unsigned char)*s++;
5784 for ( ; i <= max; i++) {
5787 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5788 for (entry = HvARRAY(stash)[i];
5790 entry = HeNEXT(entry))
5792 if (!todo[(U8)*HeKEY(entry)])
5794 gv = (GV*)HeVAL(entry);
5796 if (SvTHINKFIRST(sv)) {
5797 if (!SvREADONLY(sv) && SvROK(sv))
5802 if (SvTYPE(sv) >= SVt_PV) {
5804 if (SvPVX(sv) != Nullch)
5811 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5813 #ifdef USE_ENVIRON_ARRAY
5815 environ[0] = Nullch;
5824 Perl_sv_2io(pTHX_ SV *sv)
5830 switch (SvTYPE(sv)) {
5838 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5842 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5844 return sv_2io(SvRV(sv));
5845 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5851 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5858 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5865 return *gvp = Nullgv, Nullcv;
5866 switch (SvTYPE(sv)) {
5885 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
5886 tryAMAGICunDEREF(to_cv);
5889 if (SvTYPE(sv) == SVt_PVCV) {
5898 Perl_croak(aTHX_ "Not a subroutine reference");
5903 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
5909 if (lref && !GvCVu(gv)) {
5912 tmpsv = NEWSV(704,0);
5913 gv_efullname3(tmpsv, gv, Nullch);
5914 /* XXX this is probably not what they think they're getting.
5915 * It has the same effect as "sub name;", i.e. just a forward
5917 newSUB(start_subparse(FALSE, 0),
5918 newSVOP(OP_CONST, 0, tmpsv),
5923 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
5932 Returns true if the SV has a true value by Perl's rules.
5938 Perl_sv_true(pTHX_ register SV *sv)
5944 if ((tXpv = (XPV*)SvANY(sv)) &&
5945 (tXpv->xpv_cur > 1 ||
5946 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
5953 return SvIVX(sv) != 0;
5956 return SvNVX(sv) != 0.0;
5958 return sv_2bool(sv);
5964 Perl_sv_iv(pTHX_ register SV *sv)
5968 return (IV)SvUVX(sv);
5975 Perl_sv_uv(pTHX_ register SV *sv)
5980 return (UV)SvIVX(sv);
5986 Perl_sv_nv(pTHX_ register SV *sv)
5994 Perl_sv_pv(pTHX_ SV *sv)
6001 return sv_2pv(sv, &n_a);
6005 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6011 return sv_2pv(sv, lp);
6015 =for apidoc sv_pvn_force
6017 Get a sensible string out of the SV somehow.
6023 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6027 if (SvTHINKFIRST(sv) && !SvROK(sv))
6028 sv_force_normal(sv);
6034 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6035 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6036 PL_op_name[PL_op->op_type]);
6040 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6045 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6046 SvGROW(sv, len + 1);
6047 Move(s,SvPVX(sv),len,char);
6052 SvPOK_on(sv); /* validate pointer */
6054 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6055 PTR2UV(sv),SvPVX(sv)));
6062 Perl_sv_pvbyte(pTHX_ SV *sv)
6068 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6070 return sv_pvn(sv,lp);
6074 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6076 return sv_pvn_force(sv,lp);
6080 Perl_sv_pvutf8(pTHX_ SV *sv)
6082 sv_utf8_upgrade(sv);
6087 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6089 sv_utf8_upgrade(sv);
6090 return sv_pvn(sv,lp);
6094 =for apidoc sv_pvutf8n_force
6096 Get a sensible UTF8-encoded string out of the SV somehow. See
6103 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6105 sv_utf8_upgrade(sv);
6106 return sv_pvn_force(sv,lp);
6110 =for apidoc sv_reftype
6112 Returns a string describing what the SV is a reference to.
6118 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6120 if (ob && SvOBJECT(sv))
6121 return HvNAME(SvSTASH(sv));
6123 switch (SvTYPE(sv)) {
6137 case SVt_PVLV: return "LVALUE";
6138 case SVt_PVAV: return "ARRAY";
6139 case SVt_PVHV: return "HASH";
6140 case SVt_PVCV: return "CODE";
6141 case SVt_PVGV: return "GLOB";
6142 case SVt_PVFM: return "FORMAT";
6143 case SVt_PVIO: return "IO";
6144 default: return "UNKNOWN";
6150 =for apidoc sv_isobject
6152 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6153 object. If the SV is not an RV, or if the object is not blessed, then this
6160 Perl_sv_isobject(pTHX_ SV *sv)
6177 Returns a boolean indicating whether the SV is blessed into the specified
6178 class. This does not check for subtypes; use C<sv_derived_from> to verify
6179 an inheritance relationship.
6185 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6197 return strEQ(HvNAME(SvSTASH(sv)), name);
6203 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6204 it will be upgraded to one. If C<classname> is non-null then the new SV will
6205 be blessed in the specified package. The new SV is returned and its
6206 reference count is 1.
6212 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6218 SV_CHECK_THINKFIRST(rv);
6221 if (SvTYPE(rv) >= SVt_PVMG) {
6222 U32 refcnt = SvREFCNT(rv);
6226 SvREFCNT(rv) = refcnt;
6229 if (SvTYPE(rv) < SVt_RV)
6230 sv_upgrade(rv, SVt_RV);
6231 else if (SvTYPE(rv) > SVt_RV) {
6232 (void)SvOOK_off(rv);
6233 if (SvPVX(rv) && SvLEN(rv))
6234 Safefree(SvPVX(rv));
6244 HV* stash = gv_stashpv(classname, TRUE);
6245 (void)sv_bless(rv, stash);
6251 =for apidoc sv_setref_pv
6253 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6254 argument will be upgraded to an RV. That RV will be modified to point to
6255 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6256 into the SV. The C<classname> argument indicates the package for the
6257 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6258 will be returned and will have a reference count of 1.
6260 Do not use with other Perl types such as HV, AV, SV, CV, because those
6261 objects will become corrupted by the pointer copy process.
6263 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6269 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6272 sv_setsv(rv, &PL_sv_undef);
6276 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6281 =for apidoc sv_setref_iv
6283 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6284 argument will be upgraded to an RV. That RV will be modified to point to
6285 the new SV. The C<classname> argument indicates the package for the
6286 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6287 will be returned and will have a reference count of 1.
6293 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6295 sv_setiv(newSVrv(rv,classname), iv);
6300 =for apidoc sv_setref_nv
6302 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6303 argument will be upgraded to an RV. That RV will be modified to point to
6304 the new SV. The C<classname> argument indicates the package for the
6305 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6306 will be returned and will have a reference count of 1.
6312 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6314 sv_setnv(newSVrv(rv,classname), nv);
6319 =for apidoc sv_setref_pvn
6321 Copies a string into a new SV, optionally blessing the SV. The length of the
6322 string must be specified with C<n>. The C<rv> argument will be upgraded to
6323 an RV. That RV will be modified to point to the new SV. The C<classname>
6324 argument indicates the package for the blessing. Set C<classname> to
6325 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6326 a reference count of 1.
6328 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6334 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6336 sv_setpvn(newSVrv(rv,classname), pv, n);
6341 =for apidoc sv_bless
6343 Blesses an SV into a specified package. The SV must be an RV. The package
6344 must be designated by its stash (see C<gv_stashpv()>). The reference count
6345 of the SV is unaffected.
6351 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6355 Perl_croak(aTHX_ "Can't bless non-reference value");
6357 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6358 if (SvREADONLY(tmpRef))
6359 Perl_croak(aTHX_ PL_no_modify);
6360 if (SvOBJECT(tmpRef)) {
6361 if (SvTYPE(tmpRef) != SVt_PVIO)
6363 SvREFCNT_dec(SvSTASH(tmpRef));
6366 SvOBJECT_on(tmpRef);
6367 if (SvTYPE(tmpRef) != SVt_PVIO)
6369 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6370 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6381 S_sv_unglob(pTHX_ SV *sv)
6385 assert(SvTYPE(sv) == SVt_PVGV);
6390 SvREFCNT_dec(GvSTASH(sv));
6391 GvSTASH(sv) = Nullhv;
6393 sv_unmagic(sv, '*');
6394 Safefree(GvNAME(sv));
6397 /* need to keep SvANY(sv) in the right arena */
6398 xpvmg = new_XPVMG();
6399 StructCopy(SvANY(sv), xpvmg, XPVMG);
6400 del_XPVGV(SvANY(sv));
6403 SvFLAGS(sv) &= ~SVTYPEMASK;
6404 SvFLAGS(sv) |= SVt_PVMG;
6408 =for apidoc sv_unref_flags
6410 Unsets the RV status of the SV, and decrements the reference count of
6411 whatever was being referenced by the RV. This can almost be thought of
6412 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6413 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6414 (otherwise the decrementing is conditional on the reference count being
6415 different from one or the reference being a readonly SV).
6422 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6426 if (SvWEAKREF(sv)) {
6434 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6436 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6437 sv_2mortal(rv); /* Schedule for freeing later */
6441 =for apidoc sv_unref
6443 Unsets the RV status of the SV, and decrements the reference count of
6444 whatever was being referenced by the RV. This can almost be thought of
6445 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6446 being zero. See C<SvROK_off>.
6452 Perl_sv_unref(pTHX_ SV *sv)
6454 sv_unref_flags(sv, 0);
6458 Perl_sv_taint(pTHX_ SV *sv)
6460 sv_magic((sv), Nullsv, 't', Nullch, 0);
6464 Perl_sv_untaint(pTHX_ SV *sv)
6466 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6467 MAGIC *mg = mg_find(sv, 't');
6474 Perl_sv_tainted(pTHX_ SV *sv)
6476 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6477 MAGIC *mg = mg_find(sv, 't');
6478 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6485 =for apidoc sv_setpviv
6487 Copies an integer into the given SV, also updating its string value.
6488 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6494 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6496 char buf[TYPE_CHARS(UV)];
6498 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6500 sv_setpvn(sv, ptr, ebuf - ptr);
6505 =for apidoc sv_setpviv_mg
6507 Like C<sv_setpviv>, but also handles 'set' magic.
6513 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6515 char buf[TYPE_CHARS(UV)];
6517 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6519 sv_setpvn(sv, ptr, ebuf - ptr);
6523 #if defined(PERL_IMPLICIT_CONTEXT)
6525 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6529 va_start(args, pat);
6530 sv_vsetpvf(sv, pat, &args);
6536 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6540 va_start(args, pat);
6541 sv_vsetpvf_mg(sv, pat, &args);
6547 =for apidoc sv_setpvf
6549 Processes its arguments like C<sprintf> and sets an SV to the formatted
6550 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6556 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6559 va_start(args, pat);
6560 sv_vsetpvf(sv, pat, &args);
6565 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6567 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6571 =for apidoc sv_setpvf_mg
6573 Like C<sv_setpvf>, but also handles 'set' magic.
6579 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6582 va_start(args, pat);
6583 sv_vsetpvf_mg(sv, pat, &args);
6588 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6590 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6594 #if defined(PERL_IMPLICIT_CONTEXT)
6596 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6600 va_start(args, pat);
6601 sv_vcatpvf(sv, pat, &args);
6606 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6610 va_start(args, pat);
6611 sv_vcatpvf_mg(sv, pat, &args);
6617 =for apidoc sv_catpvf
6619 Processes its arguments like C<sprintf> and appends the formatted output
6620 to an SV. Handles 'get' magic, but not 'set' magic. C<SvSETMAGIC()> must
6621 typically be called after calling this function to handle 'set' magic.
6627 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6630 va_start(args, pat);
6631 sv_vcatpvf(sv, pat, &args);
6636 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6638 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6642 =for apidoc sv_catpvf_mg
6644 Like C<sv_catpvf>, but also handles 'set' magic.
6650 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6653 va_start(args, pat);
6654 sv_vcatpvf_mg(sv, pat, &args);
6659 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6661 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6666 =for apidoc sv_vsetpvfn
6668 Works like C<vcatpvfn> but copies the text into the SV instead of
6675 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6677 sv_setpvn(sv, "", 0);
6678 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6682 =for apidoc sv_vcatpvfn
6684 Processes its arguments like C<vsprintf> and appends the formatted output
6685 to an SV. Uses an array of SVs if the C style variable argument list is
6686 missing (NULL). When running with taint checks enabled, indicates via
6687 C<maybe_tainted> if results are untrustworthy (often due to the use of
6694 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6701 static char nullstr[] = "(null)";
6704 /* no matter what, this is a string now */
6705 (void)SvPV_force(sv, origlen);
6707 /* special-case "", "%s", and "%_" */
6710 if (patlen == 2 && pat[0] == '%') {
6714 char *s = va_arg(*args, char*);
6715 sv_catpv(sv, s ? s : nullstr);
6717 else if (svix < svmax) {
6718 sv_catsv(sv, *svargs);
6719 if (DO_UTF8(*svargs))
6725 argsv = va_arg(*args, SV*);
6726 sv_catsv(sv, argsv);
6731 /* See comment on '_' below */
6736 patend = (char*)pat + patlen;
6737 for (p = (char*)pat; p < patend; p = q) {
6740 bool vectorize = FALSE;
6747 bool has_precis = FALSE;
6749 bool is_utf = FALSE;
6752 U8 utf8buf[UTF8_MAXLEN+1];
6753 STRLEN esignlen = 0;
6755 char *eptr = Nullch;
6757 /* Times 4: a decimal digit takes more than 3 binary digits.
6758 * NV_DIG: mantissa takes than many decimal digits.
6759 * Plus 32: Playing safe. */
6760 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6761 /* large enough for "%#.#f" --chip */
6762 /* what about long double NVs? --jhi */
6765 U8 *vecstr = Null(U8*);
6777 STRLEN dotstrlen = 1;
6778 I32 epix = 0; /* explicit parameter index */
6779 I32 ewix = 0; /* explicit width index */
6780 bool asterisk = FALSE;
6782 for (q = p; q < patend && *q != '%'; ++q) ;
6784 sv_catpvn(sv, p, q - p);
6813 case '*': /* printf("%*vX",":",$ipv6addr) */
6818 vecsv = va_arg(*args, SV*);
6819 else if (svix < svmax)
6820 vecsv = svargs[svix++];
6823 dotstr = SvPVx(vecsv,dotstrlen);
6851 case '1': case '2': case '3':
6852 case '4': case '5': case '6':
6853 case '7': case '8': case '9':
6856 width = width * 10 + (*q++ - '0');
6858 if (asterisk && ewix == 0) {
6863 } else if (epix == 0) {
6875 i = va_arg(*args, int);
6877 i = (ewix ? ewix <= svmax : svix < svmax) ?
6878 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6880 width = (i < 0) ? -i : i;
6889 i = va_arg(*args, int);
6891 i = (ewix ? ewix <= svmax : svix < svmax)
6892 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
6893 precis = (i < 0) ? 0 : i;
6899 precis = precis * 10 + (*q++ - '0');
6906 vecsv = va_arg(*args, SV*);
6907 vecstr = (U8*)SvPVx(vecsv,veclen);
6908 utf = DO_UTF8(vecsv);
6910 else if (epix ? epix <= svmax : svix < svmax) {
6911 vecsv = svargs[epix ? epix-1 : svix++];
6912 vecstr = (U8*)SvPVx(vecsv,veclen);
6913 utf = DO_UTF8(vecsv);
6924 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6935 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
6936 if (*(q + 1) == 'l') { /* lld, llf */
6963 uv = va_arg(*args, int);
6965 uv = (epix ? epix <= svmax : svix < svmax) ?
6966 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
6967 if ((uv > 255 || (uv > 127 && SvUTF8(sv))) && !IN_BYTE) {
6968 eptr = (char*)utf8buf;
6969 elen = uv_to_utf8((U8*)eptr, uv) - utf8buf;
6981 eptr = va_arg(*args, char*);
6983 #ifdef MACOS_TRADITIONAL
6984 /* On MacOS, %#s format is used for Pascal strings */
6989 elen = strlen(eptr);
6992 elen = sizeof nullstr - 1;
6995 else if (epix ? epix <= svmax : svix < svmax) {
6996 argsv = svargs[epix ? epix-1 : svix++];
6997 eptr = SvPVx(argsv, elen);
6998 if (DO_UTF8(argsv)) {
6999 if (has_precis && precis < elen) {
7001 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7004 if (width) { /* fudge width (can't fudge elen) */
7005 width += elen - sv_len_utf8(argsv);
7014 * The "%_" hack might have to be changed someday,
7015 * if ISO or ANSI decide to use '_' for something.
7016 * So we keep it hidden from users' code.
7020 argsv = va_arg(*args,SV*);
7021 eptr = SvPVx(argsv, elen);
7027 if (has_precis && elen > precis)
7037 uv = PTR2UV(va_arg(*args, void*));
7039 uv = (epix ? epix <= svmax : svix < svmax) ?
7040 PTR2UV(svargs[epix ? epix-1 : svix++]) : 0;
7060 iv = (IV)utf8_to_uv(vecstr, veclen, &ulen, 0);
7070 case 'h': iv = (short)va_arg(*args, int); break;
7071 default: iv = va_arg(*args, int); break;
7072 case 'l': iv = va_arg(*args, long); break;
7073 case 'V': iv = va_arg(*args, IV); break;
7075 case 'q': iv = va_arg(*args, Quad_t); break;
7080 iv = (epix ? epix <= svmax : svix < svmax) ?
7081 SvIVx(svargs[epix ? epix-1 : svix++]) : 0;
7083 case 'h': iv = (short)iv; break;
7085 case 'l': iv = (long)iv; break;
7088 case 'q': iv = (Quad_t)iv; break;
7095 esignbuf[esignlen++] = plus;
7099 esignbuf[esignlen++] = '-';
7143 uv = utf8_to_uv(vecstr, veclen, &ulen, 0);
7153 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7154 default: uv = va_arg(*args, unsigned); break;
7155 case 'l': uv = va_arg(*args, unsigned long); break;
7156 case 'V': uv = va_arg(*args, UV); break;
7158 case 'q': uv = va_arg(*args, Quad_t); break;
7163 uv = (epix ? epix <= svmax : svix < svmax) ?
7164 SvUVx(svargs[epix ? epix-1 : svix++]) : 0;
7166 case 'h': uv = (unsigned short)uv; break;
7168 case 'l': uv = (unsigned long)uv; break;
7171 case 'q': uv = (Quad_t)uv; break;
7177 eptr = ebuf + sizeof ebuf;
7183 p = (char*)((c == 'X')
7184 ? "0123456789ABCDEF" : "0123456789abcdef");
7190 esignbuf[esignlen++] = '0';
7191 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7197 *--eptr = '0' + dig;
7199 if (alt && *eptr != '0')
7205 *--eptr = '0' + dig;
7208 esignbuf[esignlen++] = '0';
7209 esignbuf[esignlen++] = 'b';
7212 default: /* it had better be ten or less */
7213 #if defined(PERL_Y2KWARN)
7214 if (ckWARN(WARN_Y2K)) {
7216 char *s = SvPV(sv,n);
7217 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7218 && (n == 2 || !isDIGIT(s[n-3])))
7220 Perl_warner(aTHX_ WARN_Y2K,
7221 "Possible Y2K bug: %%%c %s",
7222 c, "format string following '19'");
7228 *--eptr = '0' + dig;
7229 } while (uv /= base);
7232 elen = (ebuf + sizeof ebuf) - eptr;
7235 zeros = precis - elen;
7236 else if (precis == 0 && elen == 1 && *eptr == '0')
7241 /* FLOATING POINT */
7244 c = 'f'; /* maybe %F isn't supported here */
7250 /* This is evil, but floating point is even more evil */
7254 nv = va_arg(*args, NV);
7256 nv = (epix ? epix <= svmax : svix < svmax) ?
7257 SvNVx(svargs[epix ? epix-1 : svix++]) : 0.0;
7260 if (c != 'e' && c != 'E') {
7262 (void)Perl_frexp(nv, &i);
7263 if (i == PERL_INT_MIN)
7264 Perl_die(aTHX_ "panic: frexp");
7266 need = BIT_DIGITS(i);
7268 need += has_precis ? precis : 6; /* known default */
7272 need += 20; /* fudge factor */
7273 if (PL_efloatsize < need) {
7274 Safefree(PL_efloatbuf);
7275 PL_efloatsize = need + 20; /* more fudge */
7276 New(906, PL_efloatbuf, PL_efloatsize, char);
7277 PL_efloatbuf[0] = '\0';
7280 eptr = ebuf + sizeof ebuf;
7283 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7285 /* Copy the one or more characters in a long double
7286 * format before the 'base' ([efgEFG]) character to
7287 * the format string. */
7288 static char const prifldbl[] = PERL_PRIfldbl;
7289 char const *p = prifldbl + sizeof(prifldbl) - 3;
7290 while (p >= prifldbl) { *--eptr = *p--; }
7295 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7300 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7312 /* No taint. Otherwise we are in the strange situation
7313 * where printf() taints but print($float) doesn't.
7315 (void)sprintf(PL_efloatbuf, eptr, nv);
7317 eptr = PL_efloatbuf;
7318 elen = strlen(PL_efloatbuf);
7325 i = SvCUR(sv) - origlen;
7328 case 'h': *(va_arg(*args, short*)) = i; break;
7329 default: *(va_arg(*args, int*)) = i; break;
7330 case 'l': *(va_arg(*args, long*)) = i; break;
7331 case 'V': *(va_arg(*args, IV*)) = i; break;
7333 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7337 else if (epix ? epix <= svmax : svix < svmax)
7338 sv_setuv_mg(svargs[epix ? epix-1 : svix++], (UV)i);
7339 continue; /* not "break" */
7346 if (!args && ckWARN(WARN_PRINTF) &&
7347 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7348 SV *msg = sv_newmortal();
7349 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7350 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7353 Perl_sv_catpvf(aTHX_ msg,
7354 "\"%%%c\"", c & 0xFF);
7356 Perl_sv_catpvf(aTHX_ msg,
7357 "\"%%\\%03"UVof"\"",
7360 sv_catpv(msg, "end of string");
7361 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7364 /* output mangled stuff ... */
7370 /* ... right here, because formatting flags should not apply */
7371 SvGROW(sv, SvCUR(sv) + elen + 1);
7373 memcpy(p, eptr, elen);
7376 SvCUR(sv) = p - SvPVX(sv);
7377 continue; /* not "break" */
7380 have = esignlen + zeros + elen;
7381 need = (have > width ? have : width);
7384 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7386 if (esignlen && fill == '0') {
7387 for (i = 0; i < esignlen; i++)
7391 memset(p, fill, gap);
7394 if (esignlen && fill != '0') {
7395 for (i = 0; i < esignlen; i++)
7399 for (i = zeros; i; i--)
7403 memcpy(p, eptr, elen);
7407 memset(p, ' ', gap);
7412 memcpy(p, dotstr, dotstrlen);
7416 vectorize = FALSE; /* done iterating over vecstr */
7421 SvCUR(sv) = p - SvPVX(sv);
7429 #if defined(USE_ITHREADS)
7431 #if defined(USE_THREADS)
7432 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7435 #ifndef GpREFCNT_inc
7436 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7440 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7441 #define av_dup(s) (AV*)sv_dup((SV*)s)
7442 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7443 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7444 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7445 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7446 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7447 #define io_dup(s) (IO*)sv_dup((SV*)s)
7448 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7449 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7450 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7451 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7452 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7455 Perl_re_dup(pTHX_ REGEXP *r)
7457 /* XXX fix when pmop->op_pmregexp becomes shared */
7458 return ReREFCNT_inc(r);
7462 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7466 return (PerlIO*)NULL;
7468 /* look for it in the table first */
7469 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7473 /* create anew and remember what it is */
7474 ret = PerlIO_fdupopen(aTHX_ fp);
7475 ptr_table_store(PL_ptr_table, fp, ret);
7480 Perl_dirp_dup(pTHX_ DIR *dp)
7489 Perl_gp_dup(pTHX_ GP *gp)
7494 /* look for it in the table first */
7495 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7499 /* create anew and remember what it is */
7500 Newz(0, ret, 1, GP);
7501 ptr_table_store(PL_ptr_table, gp, ret);
7504 ret->gp_refcnt = 0; /* must be before any other dups! */
7505 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7506 ret->gp_io = io_dup_inc(gp->gp_io);
7507 ret->gp_form = cv_dup_inc(gp->gp_form);
7508 ret->gp_av = av_dup_inc(gp->gp_av);
7509 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7510 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7511 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7512 ret->gp_cvgen = gp->gp_cvgen;
7513 ret->gp_flags = gp->gp_flags;
7514 ret->gp_line = gp->gp_line;
7515 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7520 Perl_mg_dup(pTHX_ MAGIC *mg)
7522 MAGIC *mgret = (MAGIC*)NULL;
7525 return (MAGIC*)NULL;
7526 /* look for it in the table first */
7527 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7531 for (; mg; mg = mg->mg_moremagic) {
7533 Newz(0, nmg, 1, MAGIC);
7537 mgprev->mg_moremagic = nmg;
7538 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7539 nmg->mg_private = mg->mg_private;
7540 nmg->mg_type = mg->mg_type;
7541 nmg->mg_flags = mg->mg_flags;
7542 if (mg->mg_type == 'r') {
7543 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7546 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7547 ? sv_dup_inc(mg->mg_obj)
7548 : sv_dup(mg->mg_obj);
7550 nmg->mg_len = mg->mg_len;
7551 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7552 if (mg->mg_ptr && mg->mg_type != 'g') {
7553 if (mg->mg_len >= 0) {
7554 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7555 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7556 AMT *amtp = (AMT*)mg->mg_ptr;
7557 AMT *namtp = (AMT*)nmg->mg_ptr;
7559 for (i = 1; i < NofAMmeth; i++) {
7560 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7564 else if (mg->mg_len == HEf_SVKEY)
7565 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7573 Perl_ptr_table_new(pTHX)
7576 Newz(0, tbl, 1, PTR_TBL_t);
7579 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7584 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7586 PTR_TBL_ENT_t *tblent;
7587 UV hash = PTR2UV(sv);
7589 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7590 for (; tblent; tblent = tblent->next) {
7591 if (tblent->oldval == sv)
7592 return tblent->newval;
7598 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7600 PTR_TBL_ENT_t *tblent, **otblent;
7601 /* XXX this may be pessimal on platforms where pointers aren't good
7602 * hash values e.g. if they grow faster in the most significant
7604 UV hash = PTR2UV(oldv);
7608 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7609 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7610 if (tblent->oldval == oldv) {
7611 tblent->newval = newv;
7616 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7617 tblent->oldval = oldv;
7618 tblent->newval = newv;
7619 tblent->next = *otblent;
7622 if (i && tbl->tbl_items > tbl->tbl_max)
7623 ptr_table_split(tbl);
7627 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7629 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7630 UV oldsize = tbl->tbl_max + 1;
7631 UV newsize = oldsize * 2;
7634 Renew(ary, newsize, PTR_TBL_ENT_t*);
7635 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7636 tbl->tbl_max = --newsize;
7638 for (i=0; i < oldsize; i++, ary++) {
7639 PTR_TBL_ENT_t **curentp, **entp, *ent;
7642 curentp = ary + oldsize;
7643 for (entp = ary, ent = *ary; ent; ent = *entp) {
7644 if ((newsize & PTR2UV(ent->oldval)) != i) {
7646 ent->next = *curentp;
7661 Perl_sv_dup(pTHX_ SV *sstr)
7665 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7667 /* look for it in the table first */
7668 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7672 /* create anew and remember what it is */
7674 ptr_table_store(PL_ptr_table, sstr, dstr);
7677 SvFLAGS(dstr) = SvFLAGS(sstr);
7678 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7679 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7682 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7683 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7684 PL_watch_pvx, SvPVX(sstr));
7687 switch (SvTYPE(sstr)) {
7692 SvANY(dstr) = new_XIV();
7693 SvIVX(dstr) = SvIVX(sstr);
7696 SvANY(dstr) = new_XNV();
7697 SvNVX(dstr) = SvNVX(sstr);
7700 SvANY(dstr) = new_XRV();
7701 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7704 SvANY(dstr) = new_XPV();
7705 SvCUR(dstr) = SvCUR(sstr);
7706 SvLEN(dstr) = SvLEN(sstr);
7708 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7709 else if (SvPVX(sstr) && SvLEN(sstr))
7710 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7712 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7715 SvANY(dstr) = new_XPVIV();
7716 SvCUR(dstr) = SvCUR(sstr);
7717 SvLEN(dstr) = SvLEN(sstr);
7718 SvIVX(dstr) = SvIVX(sstr);
7720 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7721 else if (SvPVX(sstr) && SvLEN(sstr))
7722 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7724 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7727 SvANY(dstr) = new_XPVNV();
7728 SvCUR(dstr) = SvCUR(sstr);
7729 SvLEN(dstr) = SvLEN(sstr);
7730 SvIVX(dstr) = SvIVX(sstr);
7731 SvNVX(dstr) = SvNVX(sstr);
7733 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7734 else if (SvPVX(sstr) && SvLEN(sstr))
7735 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7737 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7740 SvANY(dstr) = new_XPVMG();
7741 SvCUR(dstr) = SvCUR(sstr);
7742 SvLEN(dstr) = SvLEN(sstr);
7743 SvIVX(dstr) = SvIVX(sstr);
7744 SvNVX(dstr) = SvNVX(sstr);
7745 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7746 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7748 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7749 else if (SvPVX(sstr) && SvLEN(sstr))
7750 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7752 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7755 SvANY(dstr) = new_XPVBM();
7756 SvCUR(dstr) = SvCUR(sstr);
7757 SvLEN(dstr) = SvLEN(sstr);
7758 SvIVX(dstr) = SvIVX(sstr);
7759 SvNVX(dstr) = SvNVX(sstr);
7760 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7761 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7763 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7764 else if (SvPVX(sstr) && SvLEN(sstr))
7765 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7767 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7768 BmRARE(dstr) = BmRARE(sstr);
7769 BmUSEFUL(dstr) = BmUSEFUL(sstr);
7770 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
7773 SvANY(dstr) = new_XPVLV();
7774 SvCUR(dstr) = SvCUR(sstr);
7775 SvLEN(dstr) = SvLEN(sstr);
7776 SvIVX(dstr) = SvIVX(sstr);
7777 SvNVX(dstr) = SvNVX(sstr);
7778 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7779 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7781 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7782 else if (SvPVX(sstr) && SvLEN(sstr))
7783 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7785 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7786 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
7787 LvTARGLEN(dstr) = LvTARGLEN(sstr);
7788 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
7789 LvTYPE(dstr) = LvTYPE(sstr);
7792 SvANY(dstr) = new_XPVGV();
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 GvNAMELEN(dstr) = GvNAMELEN(sstr);
7806 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
7807 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
7808 GvFLAGS(dstr) = GvFLAGS(sstr);
7809 GvGP(dstr) = gp_dup(GvGP(sstr));
7810 (void)GpREFCNT_inc(GvGP(dstr));
7813 SvANY(dstr) = new_XPVIO();
7814 SvCUR(dstr) = SvCUR(sstr);
7815 SvLEN(dstr) = SvLEN(sstr);
7816 SvIVX(dstr) = SvIVX(sstr);
7817 SvNVX(dstr) = SvNVX(sstr);
7818 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7819 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7821 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7822 else if (SvPVX(sstr) && SvLEN(sstr))
7823 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7825 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7826 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
7827 if (IoOFP(sstr) == IoIFP(sstr))
7828 IoOFP(dstr) = IoIFP(dstr);
7830 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
7831 /* PL_rsfp_filters entries have fake IoDIRP() */
7832 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
7833 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
7835 IoDIRP(dstr) = IoDIRP(sstr);
7836 IoLINES(dstr) = IoLINES(sstr);
7837 IoPAGE(dstr) = IoPAGE(sstr);
7838 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
7839 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
7840 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
7841 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
7842 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
7843 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
7844 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
7845 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
7846 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
7847 IoTYPE(dstr) = IoTYPE(sstr);
7848 IoFLAGS(dstr) = IoFLAGS(sstr);
7851 SvANY(dstr) = new_XPVAV();
7852 SvCUR(dstr) = SvCUR(sstr);
7853 SvLEN(dstr) = SvLEN(sstr);
7854 SvIVX(dstr) = SvIVX(sstr);
7855 SvNVX(dstr) = SvNVX(sstr);
7856 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7857 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7858 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
7859 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
7860 if (AvARRAY((AV*)sstr)) {
7861 SV **dst_ary, **src_ary;
7862 SSize_t items = AvFILLp((AV*)sstr) + 1;
7864 src_ary = AvARRAY((AV*)sstr);
7865 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
7866 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
7867 SvPVX(dstr) = (char*)dst_ary;
7868 AvALLOC((AV*)dstr) = dst_ary;
7869 if (AvREAL((AV*)sstr)) {
7871 *dst_ary++ = sv_dup_inc(*src_ary++);
7875 *dst_ary++ = sv_dup(*src_ary++);
7877 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
7878 while (items-- > 0) {
7879 *dst_ary++ = &PL_sv_undef;
7883 SvPVX(dstr) = Nullch;
7884 AvALLOC((AV*)dstr) = (SV**)NULL;
7888 SvANY(dstr) = new_XPVHV();
7889 SvCUR(dstr) = SvCUR(sstr);
7890 SvLEN(dstr) = SvLEN(sstr);
7891 SvIVX(dstr) = SvIVX(sstr);
7892 SvNVX(dstr) = SvNVX(sstr);
7893 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7894 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7895 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
7896 if (HvARRAY((HV*)sstr)) {
7898 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
7899 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
7900 Newz(0, dxhv->xhv_array,
7901 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
7902 while (i <= sxhv->xhv_max) {
7903 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
7904 !!HvSHAREKEYS(sstr));
7907 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
7910 SvPVX(dstr) = Nullch;
7911 HvEITER((HV*)dstr) = (HE*)NULL;
7913 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
7914 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
7917 SvANY(dstr) = new_XPVFM();
7918 FmLINES(dstr) = FmLINES(sstr);
7922 SvANY(dstr) = new_XPVCV();
7924 SvCUR(dstr) = SvCUR(sstr);
7925 SvLEN(dstr) = SvLEN(sstr);
7926 SvIVX(dstr) = SvIVX(sstr);
7927 SvNVX(dstr) = SvNVX(sstr);
7928 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
7929 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
7930 if (SvPVX(sstr) && SvLEN(sstr))
7931 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7933 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7934 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
7935 CvSTART(dstr) = CvSTART(sstr);
7936 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
7937 CvXSUB(dstr) = CvXSUB(sstr);
7938 CvXSUBANY(dstr) = CvXSUBANY(sstr);
7939 CvGV(dstr) = gv_dup_inc(CvGV(sstr));
7940 CvDEPTH(dstr) = CvDEPTH(sstr);
7941 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
7942 /* XXX padlists are real, but pretend to be not */
7943 AvREAL_on(CvPADLIST(sstr));
7944 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7945 AvREAL_off(CvPADLIST(sstr));
7946 AvREAL_off(CvPADLIST(dstr));
7949 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
7950 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
7951 CvFLAGS(dstr) = CvFLAGS(sstr);
7954 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
7958 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
7965 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
7970 return (PERL_CONTEXT*)NULL;
7972 /* look for it in the table first */
7973 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
7977 /* create anew and remember what it is */
7978 Newz(56, ncxs, max + 1, PERL_CONTEXT);
7979 ptr_table_store(PL_ptr_table, cxs, ncxs);
7982 PERL_CONTEXT *cx = &cxs[ix];
7983 PERL_CONTEXT *ncx = &ncxs[ix];
7984 ncx->cx_type = cx->cx_type;
7985 if (CxTYPE(cx) == CXt_SUBST) {
7986 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
7989 ncx->blk_oldsp = cx->blk_oldsp;
7990 ncx->blk_oldcop = cx->blk_oldcop;
7991 ncx->blk_oldretsp = cx->blk_oldretsp;
7992 ncx->blk_oldmarksp = cx->blk_oldmarksp;
7993 ncx->blk_oldscopesp = cx->blk_oldscopesp;
7994 ncx->blk_oldpm = cx->blk_oldpm;
7995 ncx->blk_gimme = cx->blk_gimme;
7996 switch (CxTYPE(cx)) {
7998 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
7999 ? cv_dup_inc(cx->blk_sub.cv)
8000 : cv_dup(cx->blk_sub.cv));
8001 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8002 ? av_dup_inc(cx->blk_sub.argarray)
8004 ncx->blk_sub.savearray = av_dup(cx->blk_sub.savearray);
8005 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8006 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8007 ncx->blk_sub.lval = cx->blk_sub.lval;
8010 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8011 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8012 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8013 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8014 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8017 ncx->blk_loop.label = cx->blk_loop.label;
8018 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8019 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8020 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8021 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8022 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8023 ? cx->blk_loop.iterdata
8024 : gv_dup((GV*)cx->blk_loop.iterdata));
8025 ncx->blk_loop.oldcurpad
8026 = (SV**)ptr_table_fetch(PL_ptr_table,
8027 cx->blk_loop.oldcurpad);
8028 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8029 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8030 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8031 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8032 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8035 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8036 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8037 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8038 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8051 Perl_si_dup(pTHX_ PERL_SI *si)
8056 return (PERL_SI*)NULL;
8058 /* look for it in the table first */
8059 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8063 /* create anew and remember what it is */
8064 Newz(56, nsi, 1, PERL_SI);
8065 ptr_table_store(PL_ptr_table, si, nsi);
8067 nsi->si_stack = av_dup_inc(si->si_stack);
8068 nsi->si_cxix = si->si_cxix;
8069 nsi->si_cxmax = si->si_cxmax;
8070 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8071 nsi->si_type = si->si_type;
8072 nsi->si_prev = si_dup(si->si_prev);
8073 nsi->si_next = si_dup(si->si_next);
8074 nsi->si_markoff = si->si_markoff;
8079 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8080 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8081 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8082 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8083 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8084 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8085 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8086 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8087 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8088 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8089 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8090 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8093 #define pv_dup_inc(p) SAVEPV(p)
8094 #define pv_dup(p) SAVEPV(p)
8095 #define svp_dup_inc(p,pp) any_dup(p,pp)
8098 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8105 /* look for it in the table first */
8106 ret = ptr_table_fetch(PL_ptr_table, v);
8110 /* see if it is part of the interpreter structure */
8111 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8112 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8120 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8122 ANY *ss = proto_perl->Tsavestack;
8123 I32 ix = proto_perl->Tsavestack_ix;
8124 I32 max = proto_perl->Tsavestack_max;
8137 void (*dptr) (void*);
8138 void (*dxptr) (pTHXo_ void*);
8141 Newz(54, nss, max, ANY);
8147 case SAVEt_ITEM: /* normal string */
8148 sv = (SV*)POPPTR(ss,ix);
8149 TOPPTR(nss,ix) = sv_dup_inc(sv);
8150 sv = (SV*)POPPTR(ss,ix);
8151 TOPPTR(nss,ix) = sv_dup_inc(sv);
8153 case SAVEt_SV: /* scalar reference */
8154 sv = (SV*)POPPTR(ss,ix);
8155 TOPPTR(nss,ix) = sv_dup_inc(sv);
8156 gv = (GV*)POPPTR(ss,ix);
8157 TOPPTR(nss,ix) = gv_dup_inc(gv);
8159 case SAVEt_GENERIC_PVREF: /* generic char* */
8160 c = (char*)POPPTR(ss,ix);
8161 TOPPTR(nss,ix) = pv_dup(c);
8162 ptr = POPPTR(ss,ix);
8163 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8165 case SAVEt_GENERIC_SVREF: /* generic sv */
8166 case SAVEt_SVREF: /* scalar reference */
8167 sv = (SV*)POPPTR(ss,ix);
8168 TOPPTR(nss,ix) = sv_dup_inc(sv);
8169 ptr = POPPTR(ss,ix);
8170 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8172 case SAVEt_AV: /* array reference */
8173 av = (AV*)POPPTR(ss,ix);
8174 TOPPTR(nss,ix) = av_dup_inc(av);
8175 gv = (GV*)POPPTR(ss,ix);
8176 TOPPTR(nss,ix) = gv_dup(gv);
8178 case SAVEt_HV: /* hash reference */
8179 hv = (HV*)POPPTR(ss,ix);
8180 TOPPTR(nss,ix) = hv_dup_inc(hv);
8181 gv = (GV*)POPPTR(ss,ix);
8182 TOPPTR(nss,ix) = gv_dup(gv);
8184 case SAVEt_INT: /* int reference */
8185 ptr = POPPTR(ss,ix);
8186 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8187 intval = (int)POPINT(ss,ix);
8188 TOPINT(nss,ix) = intval;
8190 case SAVEt_LONG: /* long reference */
8191 ptr = POPPTR(ss,ix);
8192 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8193 longval = (long)POPLONG(ss,ix);
8194 TOPLONG(nss,ix) = longval;
8196 case SAVEt_I32: /* I32 reference */
8197 case SAVEt_I16: /* I16 reference */
8198 case SAVEt_I8: /* I8 reference */
8199 ptr = POPPTR(ss,ix);
8200 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8204 case SAVEt_IV: /* IV reference */
8205 ptr = POPPTR(ss,ix);
8206 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8210 case SAVEt_SPTR: /* SV* reference */
8211 ptr = POPPTR(ss,ix);
8212 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8213 sv = (SV*)POPPTR(ss,ix);
8214 TOPPTR(nss,ix) = sv_dup(sv);
8216 case SAVEt_VPTR: /* random* reference */
8217 ptr = POPPTR(ss,ix);
8218 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8219 ptr = POPPTR(ss,ix);
8220 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8222 case SAVEt_PPTR: /* char* reference */
8223 ptr = POPPTR(ss,ix);
8224 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8225 c = (char*)POPPTR(ss,ix);
8226 TOPPTR(nss,ix) = pv_dup(c);
8228 case SAVEt_HPTR: /* HV* reference */
8229 ptr = POPPTR(ss,ix);
8230 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8231 hv = (HV*)POPPTR(ss,ix);
8232 TOPPTR(nss,ix) = hv_dup(hv);
8234 case SAVEt_APTR: /* AV* reference */
8235 ptr = POPPTR(ss,ix);
8236 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8237 av = (AV*)POPPTR(ss,ix);
8238 TOPPTR(nss,ix) = av_dup(av);
8241 gv = (GV*)POPPTR(ss,ix);
8242 TOPPTR(nss,ix) = gv_dup(gv);
8244 case SAVEt_GP: /* scalar reference */
8245 gp = (GP*)POPPTR(ss,ix);
8246 TOPPTR(nss,ix) = gp = gp_dup(gp);
8247 (void)GpREFCNT_inc(gp);
8248 gv = (GV*)POPPTR(ss,ix);
8249 TOPPTR(nss,ix) = gv_dup_inc(c);
8250 c = (char*)POPPTR(ss,ix);
8251 TOPPTR(nss,ix) = pv_dup(c);
8258 sv = (SV*)POPPTR(ss,ix);
8259 TOPPTR(nss,ix) = sv_dup_inc(sv);
8262 ptr = POPPTR(ss,ix);
8263 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8264 /* these are assumed to be refcounted properly */
8265 switch (((OP*)ptr)->op_type) {
8272 TOPPTR(nss,ix) = ptr;
8277 TOPPTR(nss,ix) = Nullop;
8282 TOPPTR(nss,ix) = Nullop;
8285 c = (char*)POPPTR(ss,ix);
8286 TOPPTR(nss,ix) = pv_dup_inc(c);
8289 longval = POPLONG(ss,ix);
8290 TOPLONG(nss,ix) = longval;
8293 hv = (HV*)POPPTR(ss,ix);
8294 TOPPTR(nss,ix) = hv_dup_inc(hv);
8295 c = (char*)POPPTR(ss,ix);
8296 TOPPTR(nss,ix) = pv_dup_inc(c);
8300 case SAVEt_DESTRUCTOR:
8301 ptr = POPPTR(ss,ix);
8302 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8303 dptr = POPDPTR(ss,ix);
8304 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8306 case SAVEt_DESTRUCTOR_X:
8307 ptr = POPPTR(ss,ix);
8308 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8309 dxptr = POPDXPTR(ss,ix);
8310 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8312 case SAVEt_REGCONTEXT:
8318 case SAVEt_STACK_POS: /* Position on Perl stack */
8322 case SAVEt_AELEM: /* array element */
8323 sv = (SV*)POPPTR(ss,ix);
8324 TOPPTR(nss,ix) = sv_dup_inc(sv);
8327 av = (AV*)POPPTR(ss,ix);
8328 TOPPTR(nss,ix) = av_dup_inc(av);
8330 case SAVEt_HELEM: /* hash element */
8331 sv = (SV*)POPPTR(ss,ix);
8332 TOPPTR(nss,ix) = sv_dup_inc(sv);
8333 sv = (SV*)POPPTR(ss,ix);
8334 TOPPTR(nss,ix) = sv_dup_inc(sv);
8335 hv = (HV*)POPPTR(ss,ix);
8336 TOPPTR(nss,ix) = hv_dup_inc(hv);
8339 ptr = POPPTR(ss,ix);
8340 TOPPTR(nss,ix) = ptr;
8347 av = (AV*)POPPTR(ss,ix);
8348 TOPPTR(nss,ix) = av_dup(av);
8351 longval = (long)POPLONG(ss,ix);
8352 TOPLONG(nss,ix) = longval;
8353 ptr = POPPTR(ss,ix);
8354 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8355 sv = (SV*)POPPTR(ss,ix);
8356 TOPPTR(nss,ix) = sv_dup(sv);
8359 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8371 perl_clone(PerlInterpreter *proto_perl, UV flags)
8374 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8377 #ifdef PERL_IMPLICIT_SYS
8378 return perl_clone_using(proto_perl, flags,
8380 proto_perl->IMemShared,
8381 proto_perl->IMemParse,
8391 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8392 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8393 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8394 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8395 struct IPerlDir* ipD, struct IPerlSock* ipS,
8396 struct IPerlProc* ipP)
8398 /* XXX many of the string copies here can be optimized if they're
8399 * constants; they need to be allocated as common memory and just
8400 * their pointers copied. */
8404 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8406 PERL_SET_THX(pPerl);
8407 # else /* !PERL_OBJECT */
8408 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8409 PERL_SET_THX(my_perl);
8412 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8417 # else /* !DEBUGGING */
8418 Zero(my_perl, 1, PerlInterpreter);
8419 # endif /* DEBUGGING */
8423 PL_MemShared = ipMS;
8431 # endif /* PERL_OBJECT */
8432 #else /* !PERL_IMPLICIT_SYS */
8434 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8435 PERL_SET_THX(my_perl);
8438 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8443 # else /* !DEBUGGING */
8444 Zero(my_perl, 1, PerlInterpreter);
8445 # endif /* DEBUGGING */
8446 #endif /* PERL_IMPLICIT_SYS */
8449 PL_xiv_arenaroot = NULL;
8451 PL_xnv_arenaroot = NULL;
8453 PL_xrv_arenaroot = NULL;
8455 PL_xpv_arenaroot = NULL;
8457 PL_xpviv_arenaroot = NULL;
8458 PL_xpviv_root = NULL;
8459 PL_xpvnv_arenaroot = NULL;
8460 PL_xpvnv_root = NULL;
8461 PL_xpvcv_arenaroot = NULL;
8462 PL_xpvcv_root = NULL;
8463 PL_xpvav_arenaroot = NULL;
8464 PL_xpvav_root = NULL;
8465 PL_xpvhv_arenaroot = NULL;
8466 PL_xpvhv_root = NULL;
8467 PL_xpvmg_arenaroot = NULL;
8468 PL_xpvmg_root = NULL;
8469 PL_xpvlv_arenaroot = NULL;
8470 PL_xpvlv_root = NULL;
8471 PL_xpvbm_arenaroot = NULL;
8472 PL_xpvbm_root = NULL;
8473 PL_he_arenaroot = NULL;
8475 PL_nice_chunk = NULL;
8476 PL_nice_chunk_size = 0;
8479 PL_sv_root = Nullsv;
8480 PL_sv_arenaroot = Nullsv;
8482 PL_debug = proto_perl->Idebug;
8484 /* create SV map for pointer relocation */
8485 PL_ptr_table = ptr_table_new();
8487 /* initialize these special pointers as early as possible */
8488 SvANY(&PL_sv_undef) = NULL;
8489 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8490 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8491 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8494 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8496 SvANY(&PL_sv_no) = new_XPVNV();
8498 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8499 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8500 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8501 SvCUR(&PL_sv_no) = 0;
8502 SvLEN(&PL_sv_no) = 1;
8503 SvNVX(&PL_sv_no) = 0;
8504 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8507 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8509 SvANY(&PL_sv_yes) = new_XPVNV();
8511 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8512 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8513 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8514 SvCUR(&PL_sv_yes) = 1;
8515 SvLEN(&PL_sv_yes) = 2;
8516 SvNVX(&PL_sv_yes) = 1;
8517 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8519 /* create shared string table */
8520 PL_strtab = newHV();
8521 HvSHAREKEYS_off(PL_strtab);
8522 hv_ksplit(PL_strtab, 512);
8523 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8525 PL_compiling = proto_perl->Icompiling;
8526 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8527 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8528 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8529 if (!specialWARN(PL_compiling.cop_warnings))
8530 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8531 if (!specialCopIO(PL_compiling.cop_io))
8532 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8533 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8535 /* pseudo environmental stuff */
8536 PL_origargc = proto_perl->Iorigargc;
8538 New(0, PL_origargv, i+1, char*);
8539 PL_origargv[i] = '\0';
8541 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8543 PL_envgv = gv_dup(proto_perl->Ienvgv);
8544 PL_incgv = gv_dup(proto_perl->Iincgv);
8545 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8546 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8547 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8548 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8551 PL_minus_c = proto_perl->Iminus_c;
8552 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8553 PL_localpatches = proto_perl->Ilocalpatches;
8554 PL_splitstr = proto_perl->Isplitstr;
8555 PL_preprocess = proto_perl->Ipreprocess;
8556 PL_minus_n = proto_perl->Iminus_n;
8557 PL_minus_p = proto_perl->Iminus_p;
8558 PL_minus_l = proto_perl->Iminus_l;
8559 PL_minus_a = proto_perl->Iminus_a;
8560 PL_minus_F = proto_perl->Iminus_F;
8561 PL_doswitches = proto_perl->Idoswitches;
8562 PL_dowarn = proto_perl->Idowarn;
8563 PL_doextract = proto_perl->Idoextract;
8564 PL_sawampersand = proto_perl->Isawampersand;
8565 PL_unsafe = proto_perl->Iunsafe;
8566 PL_inplace = SAVEPV(proto_perl->Iinplace);
8567 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8568 PL_perldb = proto_perl->Iperldb;
8569 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8571 /* magical thingies */
8572 /* XXX time(&PL_basetime) when asked for? */
8573 PL_basetime = proto_perl->Ibasetime;
8574 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8576 PL_maxsysfd = proto_perl->Imaxsysfd;
8577 PL_multiline = proto_perl->Imultiline;
8578 PL_statusvalue = proto_perl->Istatusvalue;
8580 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8583 /* shortcuts to various I/O objects */
8584 PL_stdingv = gv_dup(proto_perl->Istdingv);
8585 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8586 PL_defgv = gv_dup(proto_perl->Idefgv);
8587 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8588 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8589 PL_argvout_stack = av_dup(proto_perl->Iargvout_stack);
8591 /* shortcuts to regexp stuff */
8592 PL_replgv = gv_dup(proto_perl->Ireplgv);
8594 /* shortcuts to misc objects */
8595 PL_errgv = gv_dup(proto_perl->Ierrgv);
8597 /* shortcuts to debugging objects */
8598 PL_DBgv = gv_dup(proto_perl->IDBgv);
8599 PL_DBline = gv_dup(proto_perl->IDBline);
8600 PL_DBsub = gv_dup(proto_perl->IDBsub);
8601 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8602 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8603 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8604 PL_lineary = av_dup(proto_perl->Ilineary);
8605 PL_dbargs = av_dup(proto_perl->Idbargs);
8608 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8609 PL_curstash = hv_dup(proto_perl->Tcurstash);
8610 PL_debstash = hv_dup(proto_perl->Idebstash);
8611 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8612 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8614 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8615 PL_endav = av_dup_inc(proto_perl->Iendav);
8616 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8617 PL_initav = av_dup_inc(proto_perl->Iinitav);
8619 PL_sub_generation = proto_perl->Isub_generation;
8621 /* funky return mechanisms */
8622 PL_forkprocess = proto_perl->Iforkprocess;
8624 /* subprocess state */
8625 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8627 /* internal state */
8628 PL_tainting = proto_perl->Itainting;
8629 PL_maxo = proto_perl->Imaxo;
8630 if (proto_perl->Iop_mask)
8631 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8633 PL_op_mask = Nullch;
8635 /* current interpreter roots */
8636 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8637 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8638 PL_main_start = proto_perl->Imain_start;
8639 PL_eval_root = proto_perl->Ieval_root;
8640 PL_eval_start = proto_perl->Ieval_start;
8642 /* runtime control stuff */
8643 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8644 PL_copline = proto_perl->Icopline;
8646 PL_filemode = proto_perl->Ifilemode;
8647 PL_lastfd = proto_perl->Ilastfd;
8648 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8651 PL_gensym = proto_perl->Igensym;
8652 PL_preambled = proto_perl->Ipreambled;
8653 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8654 PL_laststatval = proto_perl->Ilaststatval;
8655 PL_laststype = proto_perl->Ilaststype;
8656 PL_mess_sv = Nullsv;
8658 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8659 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8661 /* interpreter atexit processing */
8662 PL_exitlistlen = proto_perl->Iexitlistlen;
8663 if (PL_exitlistlen) {
8664 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8665 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8668 PL_exitlist = (PerlExitListEntry*)NULL;
8669 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8671 PL_profiledata = NULL;
8672 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8673 /* PL_rsfp_filters entries have fake IoDIRP() */
8674 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8676 PL_compcv = cv_dup(proto_perl->Icompcv);
8677 PL_comppad = av_dup(proto_perl->Icomppad);
8678 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8679 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8680 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8681 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8682 proto_perl->Tcurpad);
8684 #ifdef HAVE_INTERP_INTERN
8685 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8688 /* more statics moved here */
8689 PL_generation = proto_perl->Igeneration;
8690 PL_DBcv = cv_dup(proto_perl->IDBcv);
8692 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8693 PL_in_clean_all = proto_perl->Iin_clean_all;
8695 PL_uid = proto_perl->Iuid;
8696 PL_euid = proto_perl->Ieuid;
8697 PL_gid = proto_perl->Igid;
8698 PL_egid = proto_perl->Iegid;
8699 PL_nomemok = proto_perl->Inomemok;
8700 PL_an = proto_perl->Ian;
8701 PL_cop_seqmax = proto_perl->Icop_seqmax;
8702 PL_op_seqmax = proto_perl->Iop_seqmax;
8703 PL_evalseq = proto_perl->Ievalseq;
8704 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8705 PL_origalen = proto_perl->Iorigalen;
8706 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8707 PL_osname = SAVEPV(proto_perl->Iosname);
8708 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8709 PL_sighandlerp = proto_perl->Isighandlerp;
8712 PL_runops = proto_perl->Irunops;
8714 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8717 PL_cshlen = proto_perl->Icshlen;
8718 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8721 PL_lex_state = proto_perl->Ilex_state;
8722 PL_lex_defer = proto_perl->Ilex_defer;
8723 PL_lex_expect = proto_perl->Ilex_expect;
8724 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8725 PL_lex_dojoin = proto_perl->Ilex_dojoin;
8726 PL_lex_starts = proto_perl->Ilex_starts;
8727 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
8728 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
8729 PL_lex_op = proto_perl->Ilex_op;
8730 PL_lex_inpat = proto_perl->Ilex_inpat;
8731 PL_lex_inwhat = proto_perl->Ilex_inwhat;
8732 PL_lex_brackets = proto_perl->Ilex_brackets;
8733 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
8734 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
8735 PL_lex_casemods = proto_perl->Ilex_casemods;
8736 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
8737 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
8739 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
8740 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
8741 PL_nexttoke = proto_perl->Inexttoke;
8743 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
8744 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
8745 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8746 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
8747 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8748 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
8749 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8750 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
8751 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
8752 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8753 PL_pending_ident = proto_perl->Ipending_ident;
8754 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
8756 PL_expect = proto_perl->Iexpect;
8758 PL_multi_start = proto_perl->Imulti_start;
8759 PL_multi_end = proto_perl->Imulti_end;
8760 PL_multi_open = proto_perl->Imulti_open;
8761 PL_multi_close = proto_perl->Imulti_close;
8763 PL_error_count = proto_perl->Ierror_count;
8764 PL_subline = proto_perl->Isubline;
8765 PL_subname = sv_dup_inc(proto_perl->Isubname);
8767 PL_min_intro_pending = proto_perl->Imin_intro_pending;
8768 PL_max_intro_pending = proto_perl->Imax_intro_pending;
8769 PL_padix = proto_perl->Ipadix;
8770 PL_padix_floor = proto_perl->Ipadix_floor;
8771 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
8773 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
8774 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8775 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
8776 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
8777 PL_last_lop_op = proto_perl->Ilast_lop_op;
8778 PL_in_my = proto_perl->Iin_my;
8779 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
8781 PL_cryptseen = proto_perl->Icryptseen;
8784 PL_hints = proto_perl->Ihints;
8786 PL_amagic_generation = proto_perl->Iamagic_generation;
8788 #ifdef USE_LOCALE_COLLATE
8789 PL_collation_ix = proto_perl->Icollation_ix;
8790 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
8791 PL_collation_standard = proto_perl->Icollation_standard;
8792 PL_collxfrm_base = proto_perl->Icollxfrm_base;
8793 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
8794 #endif /* USE_LOCALE_COLLATE */
8796 #ifdef USE_LOCALE_NUMERIC
8797 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
8798 PL_numeric_standard = proto_perl->Inumeric_standard;
8799 PL_numeric_local = proto_perl->Inumeric_local;
8800 PL_numeric_radix = proto_perl->Inumeric_radix;
8801 #endif /* !USE_LOCALE_NUMERIC */
8803 /* utf8 character classes */
8804 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
8805 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
8806 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
8807 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
8808 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
8809 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
8810 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
8811 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
8812 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
8813 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
8814 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
8815 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
8816 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
8817 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
8818 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
8819 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
8820 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
8823 PL_last_swash_hv = Nullhv; /* reinits on demand */
8824 PL_last_swash_klen = 0;
8825 PL_last_swash_key[0]= '\0';
8826 PL_last_swash_tmps = (U8*)NULL;
8827 PL_last_swash_slen = 0;
8829 /* perly.c globals */
8830 PL_yydebug = proto_perl->Iyydebug;
8831 PL_yynerrs = proto_perl->Iyynerrs;
8832 PL_yyerrflag = proto_perl->Iyyerrflag;
8833 PL_yychar = proto_perl->Iyychar;
8834 PL_yyval = proto_perl->Iyyval;
8835 PL_yylval = proto_perl->Iyylval;
8837 PL_glob_index = proto_perl->Iglob_index;
8838 PL_srand_called = proto_perl->Isrand_called;
8839 PL_uudmap['M'] = 0; /* reinits on demand */
8840 PL_bitcount = Nullch; /* reinits on demand */
8842 if (proto_perl->Ipsig_ptr) {
8843 int sig_num[] = { SIG_NUM };
8844 Newz(0, PL_psig_ptr, sizeof(sig_num)/sizeof(*sig_num), SV*);
8845 Newz(0, PL_psig_name, sizeof(sig_num)/sizeof(*sig_num), SV*);
8846 for (i = 1; PL_sig_name[i]; i++) {
8847 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
8848 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
8852 PL_psig_ptr = (SV**)NULL;
8853 PL_psig_name = (SV**)NULL;
8856 /* thrdvar.h stuff */
8859 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
8860 PL_tmps_ix = proto_perl->Ttmps_ix;
8861 PL_tmps_max = proto_perl->Ttmps_max;
8862 PL_tmps_floor = proto_perl->Ttmps_floor;
8863 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
8865 while (i <= PL_tmps_ix) {
8866 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
8870 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
8871 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
8872 Newz(54, PL_markstack, i, I32);
8873 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
8874 - proto_perl->Tmarkstack);
8875 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
8876 - proto_perl->Tmarkstack);
8877 Copy(proto_perl->Tmarkstack, PL_markstack,
8878 PL_markstack_ptr - PL_markstack + 1, I32);
8880 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
8881 * NOTE: unlike the others! */
8882 PL_scopestack_ix = proto_perl->Tscopestack_ix;
8883 PL_scopestack_max = proto_perl->Tscopestack_max;
8884 Newz(54, PL_scopestack, PL_scopestack_max, I32);
8885 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
8887 /* next push_return() sets PL_retstack[PL_retstack_ix]
8888 * NOTE: unlike the others! */
8889 PL_retstack_ix = proto_perl->Tretstack_ix;
8890 PL_retstack_max = proto_perl->Tretstack_max;
8891 Newz(54, PL_retstack, PL_retstack_max, OP*);
8892 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
8894 /* NOTE: si_dup() looks at PL_markstack */
8895 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
8897 /* PL_curstack = PL_curstackinfo->si_stack; */
8898 PL_curstack = av_dup(proto_perl->Tcurstack);
8899 PL_mainstack = av_dup(proto_perl->Tmainstack);
8901 /* next PUSHs() etc. set *(PL_stack_sp+1) */
8902 PL_stack_base = AvARRAY(PL_curstack);
8903 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
8904 - proto_perl->Tstack_base);
8905 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
8907 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
8908 * NOTE: unlike the others! */
8909 PL_savestack_ix = proto_perl->Tsavestack_ix;
8910 PL_savestack_max = proto_perl->Tsavestack_max;
8911 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
8912 PL_savestack = ss_dup(proto_perl);
8916 ENTER; /* perl_destruct() wants to LEAVE; */
8919 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
8920 PL_top_env = &PL_start_env;
8922 PL_op = proto_perl->Top;
8925 PL_Xpv = (XPV*)NULL;
8926 PL_na = proto_perl->Tna;
8928 PL_statbuf = proto_perl->Tstatbuf;
8929 PL_statcache = proto_perl->Tstatcache;
8930 PL_statgv = gv_dup(proto_perl->Tstatgv);
8931 PL_statname = sv_dup_inc(proto_perl->Tstatname);
8933 PL_timesbuf = proto_perl->Ttimesbuf;
8936 PL_tainted = proto_perl->Ttainted;
8937 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
8938 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
8939 PL_rs = sv_dup_inc(proto_perl->Trs);
8940 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
8941 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
8942 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
8943 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
8944 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
8945 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
8946 PL_formtarget = sv_dup(proto_perl->Tformtarget);
8948 PL_restartop = proto_perl->Trestartop;
8949 PL_in_eval = proto_perl->Tin_eval;
8950 PL_delaymagic = proto_perl->Tdelaymagic;
8951 PL_dirty = proto_perl->Tdirty;
8952 PL_localizing = proto_perl->Tlocalizing;
8954 #ifdef PERL_FLEXIBLE_EXCEPTIONS
8955 PL_protect = proto_perl->Tprotect;
8957 PL_errors = sv_dup_inc(proto_perl->Terrors);
8958 PL_av_fetch_sv = Nullsv;
8959 PL_hv_fetch_sv = Nullsv;
8960 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
8961 PL_modcount = proto_perl->Tmodcount;
8962 PL_lastgotoprobe = Nullop;
8963 PL_dumpindent = proto_perl->Tdumpindent;
8965 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
8966 PL_sortstash = hv_dup(proto_perl->Tsortstash);
8967 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
8968 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
8969 PL_sortcxix = proto_perl->Tsortcxix;
8970 PL_efloatbuf = Nullch; /* reinits on demand */
8971 PL_efloatsize = 0; /* reinits on demand */
8975 PL_screamfirst = NULL;
8976 PL_screamnext = NULL;
8977 PL_maxscream = -1; /* reinits on demand */
8978 PL_lastscream = Nullsv;
8980 PL_watchaddr = NULL;
8981 PL_watchok = Nullch;
8983 PL_regdummy = proto_perl->Tregdummy;
8984 PL_regcomp_parse = Nullch;
8985 PL_regxend = Nullch;
8986 PL_regcode = (regnode*)NULL;
8989 PL_regprecomp = Nullch;
8994 PL_seen_zerolen = 0;
8996 PL_regcomp_rx = (regexp*)NULL;
8998 PL_colorset = 0; /* reinits PL_colors[] */
8999 /*PL_colors[6] = {0,0,0,0,0,0};*/
9000 PL_reg_whilem_seen = 0;
9001 PL_reginput = Nullch;
9004 PL_regstartp = (I32*)NULL;
9005 PL_regendp = (I32*)NULL;
9006 PL_reglastparen = (U32*)NULL;
9007 PL_regtill = Nullch;
9009 PL_reg_start_tmp = (char**)NULL;
9010 PL_reg_start_tmpl = 0;
9011 PL_regdata = (struct reg_data*)NULL;
9014 PL_reg_eval_set = 0;
9016 PL_regprogram = (regnode*)NULL;
9018 PL_regcc = (CURCUR*)NULL;
9019 PL_reg_call_cc = (struct re_cc_state*)NULL;
9020 PL_reg_re = (regexp*)NULL;
9021 PL_reg_ganch = Nullch;
9023 PL_reg_magic = (MAGIC*)NULL;
9025 PL_reg_oldcurpm = (PMOP*)NULL;
9026 PL_reg_curpm = (PMOP*)NULL;
9027 PL_reg_oldsaved = Nullch;
9028 PL_reg_oldsavedlen = 0;
9030 PL_reg_leftiter = 0;
9031 PL_reg_poscache = Nullch;
9032 PL_reg_poscache_size= 0;
9034 /* RE engine - function pointers */
9035 PL_regcompp = proto_perl->Tregcompp;
9036 PL_regexecp = proto_perl->Tregexecp;
9037 PL_regint_start = proto_perl->Tregint_start;
9038 PL_regint_string = proto_perl->Tregint_string;
9039 PL_regfree = proto_perl->Tregfree;
9041 PL_reginterp_cnt = 0;
9042 PL_reg_starttry = 0;
9045 return (PerlInterpreter*)pPerl;
9051 #else /* !USE_ITHREADS */
9057 #endif /* USE_ITHREADS */
9060 do_report_used(pTHXo_ SV *sv)
9062 if (SvTYPE(sv) != SVTYPEMASK) {
9063 PerlIO_printf(Perl_debug_log, "****\n");
9069 do_clean_objs(pTHXo_ SV *sv)
9073 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9074 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9075 if (SvWEAKREF(sv)) {
9086 /* XXX Might want to check arrays, etc. */
9089 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9091 do_clean_named_objs(pTHXo_ SV *sv)
9093 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9094 if ( SvOBJECT(GvSV(sv)) ||
9095 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9096 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9097 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9098 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9100 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9108 do_clean_all(pTHXo_ SV *sv)
9110 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9111 SvFLAGS(sv) |= SVf_BREAK;