3 * Copyright (c) 1991-2001, Larry Wall
5 * You may distribute under the terms of either the GNU General Public
6 * License or the Artistic License, as specified in the README file.
11 * "I wonder what the Entish is for 'yes' and 'no'," he thought.
19 #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv)
21 static void do_report_used(pTHXo_ SV *sv);
22 static void do_clean_objs(pTHXo_ SV *sv);
23 #ifndef DISABLE_DESTRUCTOR_KLUDGE
24 static void do_clean_named_objs(pTHXo_ SV *sv);
26 static void do_clean_all(pTHXo_ SV *sv);
29 * "A time to plant, and a time to uproot what was planted..."
34 SvANY(p) = (void *)PL_sv_root; \
35 SvFLAGS(p) = SVTYPEMASK; \
40 /* sv_mutex must be held while calling uproot_SV() */
41 #define uproot_SV(p) \
44 PL_sv_root = (SV*)SvANY(p); \
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)
158 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
159 svend = &sva[SvREFCNT(sva)];
160 for (sv = sva + 1; sv < svend; ++sv) {
161 if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
171 Perl_sv_report_used(pTHX)
173 visit(do_report_used);
177 Perl_sv_clean_objs(pTHX)
179 PL_in_clean_objs = TRUE;
180 visit(do_clean_objs);
181 #ifndef DISABLE_DESTRUCTOR_KLUDGE
182 /* some barnacles may yet remain, clinging to typeglobs */
183 visit(do_clean_named_objs);
185 PL_in_clean_objs = FALSE;
189 Perl_sv_clean_all(pTHX)
192 PL_in_clean_all = TRUE;
193 cleaned = visit(do_clean_all);
194 PL_in_clean_all = FALSE;
199 Perl_sv_free_arenas(pTHX)
203 XPV *arena, *arenanext;
205 /* Free arenas here, but be careful about fake ones. (We assume
206 contiguity of the fake ones with the corresponding real ones.) */
208 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
209 svanext = (SV*) SvANY(sva);
210 while (svanext && SvFAKE(svanext))
211 svanext = (SV*) SvANY(svanext);
214 Safefree((void *)sva);
217 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
218 arenanext = (XPV*)arena->xpv_pv;
221 PL_xiv_arenaroot = 0;
223 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
224 arenanext = (XPV*)arena->xpv_pv;
227 PL_xnv_arenaroot = 0;
229 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
230 arenanext = (XPV*)arena->xpv_pv;
233 PL_xrv_arenaroot = 0;
235 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
236 arenanext = (XPV*)arena->xpv_pv;
239 PL_xpv_arenaroot = 0;
241 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
242 arenanext = (XPV*)arena->xpv_pv;
245 PL_xpviv_arenaroot = 0;
247 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
248 arenanext = (XPV*)arena->xpv_pv;
251 PL_xpvnv_arenaroot = 0;
253 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
254 arenanext = (XPV*)arena->xpv_pv;
257 PL_xpvcv_arenaroot = 0;
259 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
260 arenanext = (XPV*)arena->xpv_pv;
263 PL_xpvav_arenaroot = 0;
265 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
266 arenanext = (XPV*)arena->xpv_pv;
269 PL_xpvhv_arenaroot = 0;
271 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
272 arenanext = (XPV*)arena->xpv_pv;
275 PL_xpvmg_arenaroot = 0;
277 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
278 arenanext = (XPV*)arena->xpv_pv;
281 PL_xpvlv_arenaroot = 0;
283 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
284 arenanext = (XPV*)arena->xpv_pv;
287 PL_xpvbm_arenaroot = 0;
289 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
290 arenanext = (XPV*)arena->xpv_pv;
296 Safefree(PL_nice_chunk);
297 PL_nice_chunk = Nullch;
298 PL_nice_chunk_size = 0;
304 Perl_report_uninit(pTHX)
307 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
308 " in ", PL_op_desc[PL_op->op_type]);
310 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
322 * See comment in more_xiv() -- RAM.
324 PL_xiv_root = *(IV**)xiv;
326 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
330 S_del_xiv(pTHX_ XPVIV *p)
332 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
334 *(IV**)xiv = PL_xiv_root;
345 New(705, ptr, 1008/sizeof(XPV), XPV);
346 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
347 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
350 xivend = &xiv[1008 / sizeof(IV) - 1];
351 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
353 while (xiv < xivend) {
354 *(IV**)xiv = (IV *)(xiv + 1);
368 PL_xnv_root = *(NV**)xnv;
370 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
374 S_del_xnv(pTHX_ XPVNV *p)
376 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
378 *(NV**)xnv = PL_xnv_root;
389 New(711, ptr, 1008/sizeof(XPV), XPV);
390 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
391 PL_xnv_arenaroot = ptr;
394 xnvend = &xnv[1008 / sizeof(NV) - 1];
395 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
397 while (xnv < xnvend) {
398 *(NV**)xnv = (NV*)(xnv + 1);
412 PL_xrv_root = (XRV*)xrv->xrv_rv;
418 S_del_xrv(pTHX_ XRV *p)
421 p->xrv_rv = (SV*)PL_xrv_root;
430 register XRV* xrvend;
432 New(712, ptr, 1008/sizeof(XPV), XPV);
433 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
434 PL_xrv_arenaroot = ptr;
437 xrvend = &xrv[1008 / sizeof(XRV) - 1];
438 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
440 while (xrv < xrvend) {
441 xrv->xrv_rv = (SV*)(xrv + 1);
455 PL_xpv_root = (XPV*)xpv->xpv_pv;
461 S_del_xpv(pTHX_ XPV *p)
464 p->xpv_pv = (char*)PL_xpv_root;
473 register XPV* xpvend;
474 New(713, xpv, 1008/sizeof(XPV), XPV);
475 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
476 PL_xpv_arenaroot = xpv;
478 xpvend = &xpv[1008 / sizeof(XPV) - 1];
480 while (xpv < xpvend) {
481 xpv->xpv_pv = (char*)(xpv + 1);
494 xpviv = PL_xpviv_root;
495 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
501 S_del_xpviv(pTHX_ XPVIV *p)
504 p->xpv_pv = (char*)PL_xpviv_root;
512 register XPVIV* xpviv;
513 register XPVIV* xpvivend;
514 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
515 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
516 PL_xpviv_arenaroot = xpviv;
518 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
519 PL_xpviv_root = ++xpviv;
520 while (xpviv < xpvivend) {
521 xpviv->xpv_pv = (char*)(xpviv + 1);
534 xpvnv = PL_xpvnv_root;
535 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
541 S_del_xpvnv(pTHX_ XPVNV *p)
544 p->xpv_pv = (char*)PL_xpvnv_root;
552 register XPVNV* xpvnv;
553 register XPVNV* xpvnvend;
554 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
555 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
556 PL_xpvnv_arenaroot = xpvnv;
558 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
559 PL_xpvnv_root = ++xpvnv;
560 while (xpvnv < xpvnvend) {
561 xpvnv->xpv_pv = (char*)(xpvnv + 1);
574 xpvcv = PL_xpvcv_root;
575 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
581 S_del_xpvcv(pTHX_ XPVCV *p)
584 p->xpv_pv = (char*)PL_xpvcv_root;
592 register XPVCV* xpvcv;
593 register XPVCV* xpvcvend;
594 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
595 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
596 PL_xpvcv_arenaroot = xpvcv;
598 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
599 PL_xpvcv_root = ++xpvcv;
600 while (xpvcv < xpvcvend) {
601 xpvcv->xpv_pv = (char*)(xpvcv + 1);
614 xpvav = PL_xpvav_root;
615 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
621 S_del_xpvav(pTHX_ XPVAV *p)
624 p->xav_array = (char*)PL_xpvav_root;
632 register XPVAV* xpvav;
633 register XPVAV* xpvavend;
634 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
635 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
636 PL_xpvav_arenaroot = xpvav;
638 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
639 PL_xpvav_root = ++xpvav;
640 while (xpvav < xpvavend) {
641 xpvav->xav_array = (char*)(xpvav + 1);
644 xpvav->xav_array = 0;
654 xpvhv = PL_xpvhv_root;
655 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
661 S_del_xpvhv(pTHX_ XPVHV *p)
664 p->xhv_array = (char*)PL_xpvhv_root;
672 register XPVHV* xpvhv;
673 register XPVHV* xpvhvend;
674 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
675 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
676 PL_xpvhv_arenaroot = xpvhv;
678 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
679 PL_xpvhv_root = ++xpvhv;
680 while (xpvhv < xpvhvend) {
681 xpvhv->xhv_array = (char*)(xpvhv + 1);
684 xpvhv->xhv_array = 0;
694 xpvmg = PL_xpvmg_root;
695 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
701 S_del_xpvmg(pTHX_ XPVMG *p)
704 p->xpv_pv = (char*)PL_xpvmg_root;
712 register XPVMG* xpvmg;
713 register XPVMG* xpvmgend;
714 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
715 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
716 PL_xpvmg_arenaroot = xpvmg;
718 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
719 PL_xpvmg_root = ++xpvmg;
720 while (xpvmg < xpvmgend) {
721 xpvmg->xpv_pv = (char*)(xpvmg + 1);
734 xpvlv = PL_xpvlv_root;
735 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
741 S_del_xpvlv(pTHX_ XPVLV *p)
744 p->xpv_pv = (char*)PL_xpvlv_root;
752 register XPVLV* xpvlv;
753 register XPVLV* xpvlvend;
754 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
755 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
756 PL_xpvlv_arenaroot = xpvlv;
758 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
759 PL_xpvlv_root = ++xpvlv;
760 while (xpvlv < xpvlvend) {
761 xpvlv->xpv_pv = (char*)(xpvlv + 1);
774 xpvbm = PL_xpvbm_root;
775 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
781 S_del_xpvbm(pTHX_ XPVBM *p)
784 p->xpv_pv = (char*)PL_xpvbm_root;
792 register XPVBM* xpvbm;
793 register XPVBM* xpvbmend;
794 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
795 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
796 PL_xpvbm_arenaroot = xpvbm;
798 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
799 PL_xpvbm_root = ++xpvbm;
800 while (xpvbm < xpvbmend) {
801 xpvbm->xpv_pv = (char*)(xpvbm + 1);
808 # define my_safemalloc(s) (void*)safexmalloc(717,s)
809 # define my_safefree(p) safexfree((char*)p)
811 # define my_safemalloc(s) (void*)safemalloc(s)
812 # define my_safefree(p) safefree((char*)p)
817 #define new_XIV() my_safemalloc(sizeof(XPVIV))
818 #define del_XIV(p) my_safefree(p)
820 #define new_XNV() my_safemalloc(sizeof(XPVNV))
821 #define del_XNV(p) my_safefree(p)
823 #define new_XRV() my_safemalloc(sizeof(XRV))
824 #define del_XRV(p) my_safefree(p)
826 #define new_XPV() my_safemalloc(sizeof(XPV))
827 #define del_XPV(p) my_safefree(p)
829 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
830 #define del_XPVIV(p) my_safefree(p)
832 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
833 #define del_XPVNV(p) my_safefree(p)
835 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
836 #define del_XPVCV(p) my_safefree(p)
838 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
839 #define del_XPVAV(p) my_safefree(p)
841 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
842 #define del_XPVHV(p) my_safefree(p)
844 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
845 #define del_XPVMG(p) my_safefree(p)
847 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
848 #define del_XPVLV(p) my_safefree(p)
850 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
851 #define del_XPVBM(p) my_safefree(p)
855 #define new_XIV() (void*)new_xiv()
856 #define del_XIV(p) del_xiv((XPVIV*) p)
858 #define new_XNV() (void*)new_xnv()
859 #define del_XNV(p) del_xnv((XPVNV*) p)
861 #define new_XRV() (void*)new_xrv()
862 #define del_XRV(p) del_xrv((XRV*) p)
864 #define new_XPV() (void*)new_xpv()
865 #define del_XPV(p) del_xpv((XPV *)p)
867 #define new_XPVIV() (void*)new_xpviv()
868 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
870 #define new_XPVNV() (void*)new_xpvnv()
871 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
873 #define new_XPVCV() (void*)new_xpvcv()
874 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
876 #define new_XPVAV() (void*)new_xpvav()
877 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
879 #define new_XPVHV() (void*)new_xpvhv()
880 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
882 #define new_XPVMG() (void*)new_xpvmg()
883 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
885 #define new_XPVLV() (void*)new_xpvlv()
886 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
888 #define new_XPVBM() (void*)new_xpvbm()
889 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
893 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
894 #define del_XPVGV(p) my_safefree(p)
896 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
897 #define del_XPVFM(p) my_safefree(p)
899 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
900 #define del_XPVIO(p) my_safefree(p)
903 =for apidoc sv_upgrade
905 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
912 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
922 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
926 if (SvTYPE(sv) == mt)
932 switch (SvTYPE(sv)) {
953 else if (mt < SVt_PVIV)
970 pv = (char*)SvRV(sv);
990 else if (mt == SVt_NV)
1001 del_XPVIV(SvANY(sv));
1011 del_XPVNV(SvANY(sv));
1019 magic = SvMAGIC(sv);
1020 stash = SvSTASH(sv);
1021 del_XPVMG(SvANY(sv));
1024 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1029 Perl_croak(aTHX_ "Can't upgrade to undef");
1031 SvANY(sv) = new_XIV();
1035 SvANY(sv) = new_XNV();
1039 SvANY(sv) = new_XRV();
1043 SvANY(sv) = new_XPV();
1049 SvANY(sv) = new_XPVIV();
1059 SvANY(sv) = new_XPVNV();
1067 SvANY(sv) = new_XPVMG();
1073 SvMAGIC(sv) = magic;
1074 SvSTASH(sv) = stash;
1077 SvANY(sv) = new_XPVLV();
1083 SvMAGIC(sv) = magic;
1084 SvSTASH(sv) = stash;
1091 SvANY(sv) = new_XPVAV();
1099 SvMAGIC(sv) = magic;
1100 SvSTASH(sv) = stash;
1106 SvANY(sv) = new_XPVHV();
1114 SvMAGIC(sv) = magic;
1115 SvSTASH(sv) = stash;
1122 SvANY(sv) = new_XPVCV();
1123 Zero(SvANY(sv), 1, XPVCV);
1129 SvMAGIC(sv) = magic;
1130 SvSTASH(sv) = stash;
1133 SvANY(sv) = new_XPVGV();
1139 SvMAGIC(sv) = magic;
1140 SvSTASH(sv) = stash;
1148 SvANY(sv) = new_XPVBM();
1154 SvMAGIC(sv) = magic;
1155 SvSTASH(sv) = stash;
1161 SvANY(sv) = new_XPVFM();
1162 Zero(SvANY(sv), 1, XPVFM);
1168 SvMAGIC(sv) = magic;
1169 SvSTASH(sv) = stash;
1172 SvANY(sv) = new_XPVIO();
1173 Zero(SvANY(sv), 1, XPVIO);
1179 SvMAGIC(sv) = magic;
1180 SvSTASH(sv) = stash;
1181 IoPAGE_LEN(sv) = 60;
1184 SvFLAGS(sv) &= ~SVTYPEMASK;
1190 Perl_sv_backoff(pTHX_ register SV *sv)
1194 char *s = SvPVX(sv);
1195 SvLEN(sv) += SvIVX(sv);
1196 SvPVX(sv) -= SvIVX(sv);
1198 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1200 SvFLAGS(sv) &= ~SVf_OOK;
1207 Expands the character buffer in the SV. This will use C<sv_unref> and will
1208 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1215 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1219 #ifdef HAS_64K_LIMIT
1220 if (newlen >= 0x10000) {
1221 PerlIO_printf(Perl_debug_log,
1222 "Allocation too large: %"UVxf"\n", (UV)newlen);
1225 #endif /* HAS_64K_LIMIT */
1228 if (SvTYPE(sv) < SVt_PV) {
1229 sv_upgrade(sv, SVt_PV);
1232 else if (SvOOK(sv)) { /* pv is offset? */
1235 if (newlen > SvLEN(sv))
1236 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1237 #ifdef HAS_64K_LIMIT
1238 if (newlen >= 0x10000)
1244 if (newlen > SvLEN(sv)) { /* need more room? */
1245 if (SvLEN(sv) && s) {
1246 #if defined(MYMALLOC) && !defined(LEAKTEST)
1247 STRLEN l = malloced_size((void*)SvPVX(sv));
1253 Renew(s,newlen,char);
1256 New(703,s,newlen,char);
1258 SvLEN_set(sv, newlen);
1264 =for apidoc sv_setiv
1266 Copies an integer into the given SV. Does not handle 'set' magic. See
1273 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1275 SV_CHECK_THINKFIRST(sv);
1276 switch (SvTYPE(sv)) {
1278 sv_upgrade(sv, SVt_IV);
1281 sv_upgrade(sv, SVt_PVNV);
1285 sv_upgrade(sv, SVt_PVIV);
1294 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1295 PL_op_desc[PL_op->op_type]);
1297 (void)SvIOK_only(sv); /* validate number */
1303 =for apidoc sv_setiv_mg
1305 Like C<sv_setiv>, but also handles 'set' magic.
1311 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1318 =for apidoc sv_setuv
1320 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1327 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1329 /* With these two if statements:
1330 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1333 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1335 If you wish to remove them, please benchmark to see what the effect is
1337 if (u <= (UV)IV_MAX) {
1338 sv_setiv(sv, (IV)u);
1347 =for apidoc sv_setuv_mg
1349 Like C<sv_setuv>, but also handles 'set' magic.
1355 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1357 /* With these two if statements:
1358 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1361 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1363 If you wish to remove them, please benchmark to see what the effect is
1365 if (u <= (UV)IV_MAX) {
1366 sv_setiv(sv, (IV)u);
1376 =for apidoc sv_setnv
1378 Copies a double into the given SV. Does not handle 'set' magic. See
1385 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1387 SV_CHECK_THINKFIRST(sv);
1388 switch (SvTYPE(sv)) {
1391 sv_upgrade(sv, SVt_NV);
1396 sv_upgrade(sv, SVt_PVNV);
1405 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1406 PL_op_name[PL_op->op_type]);
1409 (void)SvNOK_only(sv); /* validate number */
1414 =for apidoc sv_setnv_mg
1416 Like C<sv_setnv>, but also handles 'set' magic.
1422 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1429 S_not_a_number(pTHX_ SV *sv)
1433 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1434 /* each *s can expand to 4 chars + "...\0",
1435 i.e. need room for 8 chars */
1438 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1440 if (ch & 128 && !isPRINT_LC(ch)) {
1449 else if (ch == '\r') {
1453 else if (ch == '\f') {
1457 else if (ch == '\\') {
1461 else if (ch == '\0') {
1465 else if (isPRINT_LC(ch))
1480 Perl_warner(aTHX_ WARN_NUMERIC,
1481 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1482 PL_op_desc[PL_op->op_type]);
1484 Perl_warner(aTHX_ WARN_NUMERIC,
1485 "Argument \"%s\" isn't numeric", tmpbuf);
1488 /* the number can be converted to integer with atol() or atoll() although */
1489 #define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
1490 #define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
1491 #define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
1492 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1493 #define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
1494 #define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
1495 #define IS_NUMBER_NEG 0x40 /* seen a leading - */
1496 #define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
1498 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1499 until proven guilty, assume that things are not that bad... */
1501 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1502 an IV (an assumption perl has been based on to date) it becomes necessary
1503 to remove the assumption that the NV always carries enough precision to
1504 recreate the IV whenever needed, and that the NV is the canonical form.
1505 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1506 precision as an side effect of conversion (which would lead to insanity
1507 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1508 1) to distinguish between IV/UV/NV slots that have cached a valid
1509 conversion where precision was lost and IV/UV/NV slots that have a
1510 valid conversion which has lost no precision
1511 2) to ensure that if a numeric conversion to one form is request that
1512 would lose precision, the precise conversion (or differently
1513 imprecise conversion) is also performed and cached, to prevent
1514 requests for different numeric formats on the same SV causing
1515 lossy conversion chains. (lossless conversion chains are perfectly
1520 SvIOKp is true if the IV slot contains a valid value
1521 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1522 SvNOKp is true if the NV slot contains a valid value
1523 SvNOK is true only if the NV value is accurate
1526 while converting from PV to NV check to see if converting that NV to an
1527 IV(or UV) would lose accuracy over a direct conversion from PV to
1528 IV(or UV). If it would, cache both conversions, return NV, but mark
1529 SV as IOK NOKp (ie not NOK).
1531 while converting from PV to IV check to see if converting that IV to an
1532 NV would lose accuracy over a direct conversion from PV to NV. If it
1533 would, cache both conversions, flag similarly.
1535 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1536 correctly because if IV & NV were set NV *always* overruled.
1537 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1538 changes - now IV and NV together means that the two are interchangeable
1539 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1541 The benefit of this is operations such as pp_add know that if SvIOK is
1542 true for both left and right operands, then integer addition can be
1543 used instead of floating point. (for cases where the result won't
1544 overflow) Before, floating point was always used, which could lead to
1545 loss of precision compared with integer addition.
1547 * making IV and NV equal status should make maths accurate on 64 bit
1549 * may speed up maths somewhat if pp_add and friends start to use
1550 integers when possible instead of fp. (hopefully the overhead in
1551 looking for SvIOK and checking for overflow will not outweigh the
1552 fp to integer speedup)
1553 * will slow down integer operations (callers of SvIV) on "inaccurate"
1554 values, as the change from SvIOK to SvIOKp will cause a call into
1555 sv_2iv each time rather than a macro access direct to the IV slot
1556 * should speed up number->string conversion on integers as IV is
1557 favoured when IV and NV equally accurate
1559 ####################################################################
1560 You had better be using SvIOK_notUV if you want an IV for arithmetic
1561 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1562 SvUOK is true iff UV.
1563 ####################################################################
1565 Your mileage will vary depending your CPUs relative fp to integer
1569 #ifndef NV_PRESERVES_UV
1570 #define IS_NUMBER_UNDERFLOW_IV 1
1571 #define IS_NUMBER_UNDERFLOW_UV 2
1572 #define IS_NUMBER_IV_AND_UV 2
1573 #define IS_NUMBER_OVERFLOW_IV 4
1574 #define IS_NUMBER_OVERFLOW_UV 5
1575 /* Hopefully your optimiser will consider inlining these two functions. */
1577 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1578 NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
1579 UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
1580 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, (UV)numtype));
1581 if (nv_as_uv <= (UV)IV_MAX) {
1582 (void)SvIOKp_on(sv);
1583 (void)SvNOKp_on(sv);
1584 /* Within suitable range to fit in an IV, atol won't overflow */
1585 /* XXX quite sure? Is that your final answer? not really, I'm
1586 trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1587 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1588 if (numtype & IS_NUMBER_NOT_INT) {
1589 /* I believe that even if the original PV had decimals, they
1590 are lost beyond the limit of the FP precision.
1591 However, neither is canonical, so both only get p flags.
1593 /* Both already have p flags, so do nothing */
1594 } else if (SvIVX(sv) == I_V(nv)) {
1599 /* It had no "." so it must be integer. assert (get in here from
1600 sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1601 IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1602 conversion routines need audit. */
1604 return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1606 /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1607 (void)SvIOKp_on(sv);
1608 (void)SvNOKp_on(sv);
1611 int save_errno = errno;
1613 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1615 if (numtype & IS_NUMBER_NOT_INT) {
1616 /* UV and NV both imprecise. */
1618 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1627 return IS_NUMBER_OVERFLOW_IV;
1631 /* Must have just overflowed UV, but not enough that an NV could spot
1633 return IS_NUMBER_OVERFLOW_UV;
1636 /* We've just lost integer precision, nothing we could do. */
1637 SvUVX(sv) = nv_as_uv;
1638 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, (UV)numtype));
1639 /* UV and NV slots equally valid only if we have casting symmetry. */
1640 if (numtype & IS_NUMBER_NOT_INT) {
1642 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1643 /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1644 UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1645 get to this point if NVs don't preserve UVs) */
1650 /* As above, I believe UV at least as good as NV */
1653 #endif /* HAS_STRTOUL */
1654 return IS_NUMBER_OVERFLOW_IV;
1657 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1659 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1661 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), SvNVX(sv), (UV)numtype));
1662 if (SvNVX(sv) < (NV)IV_MIN) {
1663 (void)SvIOKp_on(sv);
1666 return IS_NUMBER_UNDERFLOW_IV;
1668 if (SvNVX(sv) > (NV)UV_MAX) {
1669 (void)SvIOKp_on(sv);
1673 return IS_NUMBER_OVERFLOW_UV;
1675 if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1676 (void)SvIOKp_on(sv);
1678 /* Can't use strtol etc to convert this string */
1679 if (SvNVX(sv) <= (UV)IV_MAX) {
1680 SvIVX(sv) = I_V(SvNVX(sv));
1681 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1682 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1684 /* Integer is imprecise. NOK, IOKp */
1686 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1689 SvUVX(sv) = U_V(SvNVX(sv));
1690 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1691 if (SvUVX(sv) == UV_MAX) {
1692 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1693 possibly be preserved by NV. Hence, it must be overflow.
1695 return IS_NUMBER_OVERFLOW_UV;
1697 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1699 /* Integer is imprecise. NOK, IOKp */
1701 return IS_NUMBER_OVERFLOW_IV;
1703 return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
1705 #endif /* NV_PRESERVES_UV*/
1708 Perl_sv_2iv(pTHX_ register SV *sv)
1712 if (SvGMAGICAL(sv)) {
1717 return I_V(SvNVX(sv));
1719 if (SvPOKp(sv) && SvLEN(sv))
1722 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1723 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1729 if (SvTHINKFIRST(sv)) {
1732 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1733 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1734 return SvIV(tmpstr);
1735 return PTR2IV(SvRV(sv));
1737 if (SvREADONLY(sv) && SvFAKE(sv)) {
1738 sv_force_normal(sv);
1740 if (SvREADONLY(sv) && !SvOK(sv)) {
1741 if (ckWARN(WARN_UNINITIALIZED))
1748 return (IV)(SvUVX(sv));
1755 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1756 * without also getting a cached IV/UV from it at the same time
1757 * (ie PV->NV conversion should detect loss of accuracy and cache
1758 * IV or UV at same time to avoid this. NWC */
1760 if (SvTYPE(sv) == SVt_NV)
1761 sv_upgrade(sv, SVt_PVNV);
1763 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1764 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1765 certainly cast into the IV range at IV_MAX, whereas the correct
1766 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1768 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1769 SvIVX(sv) = I_V(SvNVX(sv));
1770 if (SvNVX(sv) == (NV) SvIVX(sv)
1771 #ifndef NV_PRESERVES_UV
1772 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1773 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1774 /* Don't flag it as "accurately an integer" if the number
1775 came from a (by definition imprecise) NV operation, and
1776 we're outside the range of NV integer precision */
1779 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1780 DEBUG_c(PerlIO_printf(Perl_debug_log,
1781 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1787 /* IV not precise. No need to convert from PV, as NV
1788 conversion would already have cached IV if it detected
1789 that PV->IV would be better than PV->NV->IV
1790 flags already correct - don't set public IOK. */
1791 DEBUG_c(PerlIO_printf(Perl_debug_log,
1792 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1797 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1798 but the cast (NV)IV_MIN rounds to a the value less (more
1799 negative) than IV_MIN which happens to be equal to SvNVX ??
1800 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1801 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1802 (NV)UVX == NVX are both true, but the values differ. :-(
1803 Hopefully for 2s complement IV_MIN is something like
1804 0x8000000000000000 which will be exact. NWC */
1807 SvUVX(sv) = U_V(SvNVX(sv));
1809 (SvNVX(sv) == (NV) SvUVX(sv))
1810 #ifndef NV_PRESERVES_UV
1811 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1812 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1813 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1814 /* Don't flag it as "accurately an integer" if the number
1815 came from a (by definition imprecise) NV operation, and
1816 we're outside the range of NV integer precision */
1822 DEBUG_c(PerlIO_printf(Perl_debug_log,
1823 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1827 return (IV)SvUVX(sv);
1830 else if (SvPOKp(sv) && SvLEN(sv)) {
1831 I32 numtype = looks_like_number(sv);
1833 /* We want to avoid a possible problem when we cache an IV which
1834 may be later translated to an NV, and the resulting NV is not
1835 the translation of the initial data.
1837 This means that if we cache such an IV, we need to cache the
1838 NV as well. Moreover, we trade speed for space, and do not
1839 cache the NV if we are sure it's not needed.
1842 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1843 /* The NV may be reconstructed from IV - safe to cache IV,
1844 which may be calculated by atol(). */
1845 if (SvTYPE(sv) < SVt_PVIV)
1846 sv_upgrade(sv, SVt_PVIV);
1848 SvIVX(sv) = Atol(SvPVX(sv));
1852 int save_errno = errno;
1853 /* Is it an integer that we could convert with strtol?
1854 So try it, and if it doesn't set errno then it's pukka.
1855 This should be faster than going atof and then thinking. */
1856 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1857 == IS_NUMBER_TO_INT_BY_STRTOL)
1858 /* && is a sequence point. Without it not sure if I'm trying
1859 to do too much between sequence points and hence going
1861 && ((errno = 0), 1) /* , 1 so always true */
1862 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1864 if (SvTYPE(sv) < SVt_PVIV)
1865 sv_upgrade(sv, SVt_PVIV);
1874 /* Hopefully trace flow will optimise this away where possible
1878 /* It wasn't an integer, or it overflowed, or we don't have
1879 strtol. Do things the slow way - check if it's a UV etc. */
1880 d = Atof(SvPVX(sv));
1882 if (SvTYPE(sv) < SVt_PVNV)
1883 sv_upgrade(sv, SVt_PVNV);
1886 if (! numtype && ckWARN(WARN_NUMERIC))
1889 #if defined(USE_LONG_DOUBLE)
1890 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1891 PTR2UV(sv), SvNVX(sv)));
1893 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1894 PTR2UV(sv), SvNVX(sv)));
1898 #ifdef NV_PRESERVES_UV
1899 (void)SvIOKp_on(sv);
1901 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1902 SvIVX(sv) = I_V(SvNVX(sv));
1903 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1906 /* Integer is imprecise. NOK, IOKp */
1908 /* UV will not work better than IV */
1910 if (SvNVX(sv) > (NV)UV_MAX) {
1912 /* Integer is inaccurate. NOK, IOKp, is UV */
1916 SvUVX(sv) = U_V(SvNVX(sv));
1917 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1918 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1922 /* Integer is imprecise. NOK, IOKp, is UV */
1928 #else /* NV_PRESERVES_UV */
1929 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1930 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1931 /* Small enough to preserve all bits. */
1932 (void)SvIOKp_on(sv);
1934 SvIVX(sv) = I_V(SvNVX(sv));
1935 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1937 /* Assumption: first non-preserved integer is < IV_MAX,
1938 this NV is in the preserved range, therefore: */
1939 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1941 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);
1943 } else if (sv_2iuv_non_preserve (sv, numtype)
1944 >= IS_NUMBER_OVERFLOW_IV)
1946 #endif /* NV_PRESERVES_UV */
1950 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1952 if (SvTYPE(sv) < SVt_IV)
1953 /* Typically the caller expects that sv_any is not NULL now. */
1954 sv_upgrade(sv, SVt_IV);
1957 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1958 PTR2UV(sv),SvIVX(sv)));
1959 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1963 Perl_sv_2uv(pTHX_ register SV *sv)
1967 if (SvGMAGICAL(sv)) {
1972 return U_V(SvNVX(sv));
1973 if (SvPOKp(sv) && SvLEN(sv))
1976 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1977 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1983 if (SvTHINKFIRST(sv)) {
1986 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1987 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1988 return SvUV(tmpstr);
1989 return PTR2UV(SvRV(sv));
1991 if (SvREADONLY(sv) && SvFAKE(sv)) {
1992 sv_force_normal(sv);
1994 if (SvREADONLY(sv) && !SvOK(sv)) {
1995 if (ckWARN(WARN_UNINITIALIZED))
2005 return (UV)SvIVX(sv);
2009 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2010 * without also getting a cached IV/UV from it at the same time
2011 * (ie PV->NV conversion should detect loss of accuracy and cache
2012 * IV or UV at same time to avoid this. */
2013 /* IV-over-UV optimisation - choose to cache IV if possible */
2015 if (SvTYPE(sv) == SVt_NV)
2016 sv_upgrade(sv, SVt_PVNV);
2018 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2019 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2020 SvIVX(sv) = I_V(SvNVX(sv));
2021 if (SvNVX(sv) == (NV) SvIVX(sv)
2022 #ifndef NV_PRESERVES_UV
2023 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2024 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2025 /* Don't flag it as "accurately an integer" if the number
2026 came from a (by definition imprecise) NV operation, and
2027 we're outside the range of NV integer precision */
2030 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2031 DEBUG_c(PerlIO_printf(Perl_debug_log,
2032 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2038 /* IV not precise. No need to convert from PV, as NV
2039 conversion would already have cached IV if it detected
2040 that PV->IV would be better than PV->NV->IV
2041 flags already correct - don't set public IOK. */
2042 DEBUG_c(PerlIO_printf(Perl_debug_log,
2043 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2048 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2049 but the cast (NV)IV_MIN rounds to a the value less (more
2050 negative) than IV_MIN which happens to be equal to SvNVX ??
2051 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2052 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2053 (NV)UVX == NVX are both true, but the values differ. :-(
2054 Hopefully for 2s complement IV_MIN is something like
2055 0x8000000000000000 which will be exact. NWC */
2058 SvUVX(sv) = U_V(SvNVX(sv));
2060 (SvNVX(sv) == (NV) SvUVX(sv))
2061 #ifndef NV_PRESERVES_UV
2062 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2063 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2064 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2065 /* Don't flag it as "accurately an integer" if the number
2066 came from a (by definition imprecise) NV operation, and
2067 we're outside the range of NV integer precision */
2072 DEBUG_c(PerlIO_printf(Perl_debug_log,
2073 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2079 else if (SvPOKp(sv) && SvLEN(sv)) {
2080 I32 numtype = looks_like_number(sv);
2082 /* We want to avoid a possible problem when we cache a UV which
2083 may be later translated to an NV, and the resulting NV is not
2084 the translation of the initial data.
2086 This means that if we cache such a UV, we need to cache the
2087 NV as well. Moreover, we trade speed for space, and do not
2088 cache the NV if not needed.
2091 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2092 /* The NV may be reconstructed from IV - safe to cache IV,
2093 which may be calculated by atol(). */
2094 if (SvTYPE(sv) < SVt_PVIV)
2095 sv_upgrade(sv, SVt_PVIV);
2097 SvIVX(sv) = Atol(SvPVX(sv));
2101 char *num_begin = SvPVX(sv);
2102 int save_errno = errno;
2104 /* seems that strtoul taking numbers that start with - is
2105 implementation dependant, and can't be relied upon. */
2106 if (numtype & IS_NUMBER_NEG) {
2107 /* Not totally defensive. assumine that looks_like_num
2108 didn't lie about a - sign */
2109 while (isSPACE(*num_begin))
2111 if (*num_begin == '-')
2115 /* Is it an integer that we could convert with strtoul?
2116 So try it, and if it doesn't set errno then it's pukka.
2117 This should be faster than going atof and then thinking. */
2118 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2119 == IS_NUMBER_TO_INT_BY_STRTOL)
2120 && ((errno = 0), 1) /* always true */
2121 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2123 /* If known to be negative, check it didn't undeflow IV
2124 XXX possibly we should put more negative values as NVs
2125 direct rather than go via atof below */
2126 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2129 if (SvTYPE(sv) < SVt_PVIV)
2130 sv_upgrade(sv, SVt_PVIV);
2133 /* If it's negative must use IV.
2134 IV-over-UV optimisation */
2135 if (numtype & IS_NUMBER_NEG) {
2137 } else if (u <= (UV) IV_MAX) {
2140 /* it didn't overflow, and it was positive. */
2149 /* Hopefully trace flow will optimise this away where possible
2153 /* It wasn't an integer, or it overflowed, or we don't have
2154 strtol. Do things the slow way - check if it's a IV etc. */
2155 d = Atof(SvPVX(sv));
2157 if (SvTYPE(sv) < SVt_PVNV)
2158 sv_upgrade(sv, SVt_PVNV);
2161 if (! numtype && ckWARN(WARN_NUMERIC))
2164 #if defined(USE_LONG_DOUBLE)
2165 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2166 PTR2UV(sv), SvNVX(sv)));
2168 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2169 PTR2UV(sv), SvNVX(sv)));
2172 #ifdef NV_PRESERVES_UV
2173 (void)SvIOKp_on(sv);
2175 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2176 SvIVX(sv) = I_V(SvNVX(sv));
2177 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2180 /* Integer is imprecise. NOK, IOKp */
2182 /* UV will not work better than IV */
2184 if (SvNVX(sv) > (NV)UV_MAX) {
2186 /* Integer is inaccurate. NOK, IOKp, is UV */
2190 SvUVX(sv) = U_V(SvNVX(sv));
2191 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2192 NV preservse UV so can do correct comparison. */
2193 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2197 /* Integer is imprecise. NOK, IOKp, is UV */
2202 #else /* NV_PRESERVES_UV */
2203 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2204 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2205 /* Small enough to preserve all bits. */
2206 (void)SvIOKp_on(sv);
2208 SvIVX(sv) = I_V(SvNVX(sv));
2209 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2211 /* Assumption: first non-preserved integer is < IV_MAX,
2212 this NV is in the preserved range, therefore: */
2213 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2215 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);
2218 sv_2iuv_non_preserve (sv, numtype);
2219 #endif /* NV_PRESERVES_UV */
2224 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2225 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2228 if (SvTYPE(sv) < SVt_IV)
2229 /* Typically the caller expects that sv_any is not NULL now. */
2230 sv_upgrade(sv, SVt_IV);
2234 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2235 PTR2UV(sv),SvUVX(sv)));
2236 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2240 Perl_sv_2nv(pTHX_ register SV *sv)
2244 if (SvGMAGICAL(sv)) {
2248 if (SvPOKp(sv) && SvLEN(sv)) {
2249 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2251 return Atof(SvPVX(sv));
2255 return (NV)SvUVX(sv);
2257 return (NV)SvIVX(sv);
2260 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2261 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2267 if (SvTHINKFIRST(sv)) {
2270 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2271 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2272 return SvNV(tmpstr);
2273 return PTR2NV(SvRV(sv));
2275 if (SvREADONLY(sv) && SvFAKE(sv)) {
2276 sv_force_normal(sv);
2278 if (SvREADONLY(sv) && !SvOK(sv)) {
2279 if (ckWARN(WARN_UNINITIALIZED))
2284 if (SvTYPE(sv) < SVt_NV) {
2285 if (SvTYPE(sv) == SVt_IV)
2286 sv_upgrade(sv, SVt_PVNV);
2288 sv_upgrade(sv, SVt_NV);
2289 #if defined(USE_LONG_DOUBLE)
2291 STORE_NUMERIC_LOCAL_SET_STANDARD();
2292 PerlIO_printf(Perl_debug_log,
2293 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2294 PTR2UV(sv), SvNVX(sv));
2295 RESTORE_NUMERIC_LOCAL();
2299 STORE_NUMERIC_LOCAL_SET_STANDARD();
2300 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2301 PTR2UV(sv), SvNVX(sv));
2302 RESTORE_NUMERIC_LOCAL();
2306 else if (SvTYPE(sv) < SVt_PVNV)
2307 sv_upgrade(sv, SVt_PVNV);
2309 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2311 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2312 #ifdef NV_PRESERVES_UV
2315 /* Only set the public NV OK flag if this NV preserves the IV */
2316 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2317 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2318 : (SvIVX(sv) == I_V(SvNVX(sv))))
2324 else if (SvPOKp(sv) && SvLEN(sv)) {
2325 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2327 SvNVX(sv) = Atof(SvPVX(sv));
2328 #ifdef NV_PRESERVES_UV
2331 /* Only set the public NV OK flag if this NV preserves the value in
2332 the PV at least as well as an IV/UV would.
2333 Not sure how to do this 100% reliably. */
2334 /* if that shift count is out of range then Configure's test is
2335 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2337 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2338 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2339 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2340 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2341 /* Definitely too large/small to fit in an integer, so no loss
2342 of precision going to integer in the future via NV */
2345 /* Is it something we can run through strtol etc (ie no
2346 trailing exponent part)? */
2347 int numtype = looks_like_number(sv);
2348 /* XXX probably should cache this if called above */
2351 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2352 /* Can't use strtol etc to convert this string, so don't try */
2355 sv_2inuv_non_preserve (sv, numtype);
2357 #endif /* NV_PRESERVES_UV */
2360 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2362 if (SvTYPE(sv) < SVt_NV)
2363 /* Typically the caller expects that sv_any is not NULL now. */
2364 /* XXX Ilya implies that this is a bug in callers that assume this
2365 and ideally should be fixed. */
2366 sv_upgrade(sv, SVt_NV);
2369 #if defined(USE_LONG_DOUBLE)
2371 STORE_NUMERIC_LOCAL_SET_STANDARD();
2372 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2373 PTR2UV(sv), SvNVX(sv));
2374 RESTORE_NUMERIC_LOCAL();
2378 STORE_NUMERIC_LOCAL_SET_STANDARD();
2379 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2380 PTR2UV(sv), SvNVX(sv));
2381 RESTORE_NUMERIC_LOCAL();
2388 S_asIV(pTHX_ SV *sv)
2390 I32 numtype = looks_like_number(sv);
2393 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2394 return Atol(SvPVX(sv));
2396 if (ckWARN(WARN_NUMERIC))
2399 d = Atof(SvPVX(sv));
2404 S_asUV(pTHX_ SV *sv)
2406 I32 numtype = looks_like_number(sv);
2409 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2410 return Strtoul(SvPVX(sv), Null(char**), 10);
2413 if (ckWARN(WARN_NUMERIC))
2416 return U_V(Atof(SvPVX(sv)));
2420 * Returns a combination of (advisory only - can get false negatives)
2421 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2422 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2423 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2424 * 0 if does not look like number.
2426 * (atol and strtol stop when they hit a decimal point. strtol will return
2427 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2428 * do this, and vendors have had 11 years to get it right.
2429 * However, will try to make it still work with only atol
2431 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2432 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2433 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2434 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2435 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2436 * IS_NUMBER_NOT_INT saw "." or "e"
2438 * IS_NUMBER_INFINITY
2442 =for apidoc looks_like_number
2444 Test if an the content of an SV looks like a number (or is a
2445 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2446 issue a non-numeric warning), even if your atof() doesn't grok them.
2452 Perl_looks_like_number(pTHX_ SV *sv)
2455 register char *send;
2456 register char *sbegin;
2457 register char *nbegin;
2461 #ifdef USE_LOCALE_NUMERIC
2462 bool specialradix = FALSE;
2469 else if (SvPOKp(sv))
2470 sbegin = SvPV(sv, len);
2473 send = sbegin + len;
2480 numtype = IS_NUMBER_NEG;
2487 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2488 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2489 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2490 * will need (int)atof().
2493 /* next must be digit or the radix separator or beginning of infinity */
2497 } while (isDIGIT(*s));
2499 /* Aaargh. long long really is irritating.
2500 In the gospel according to ANSI 1989, it is an axiom that "long"
2501 is the longest integer type, and that if you don't know how long
2502 something is you can cast it to long, and nothing will be lost
2503 (except possibly speed of execution if long is slower than the
2505 Now, one can't be sure if the old rules apply, or long long
2506 (or some other newfangled thing) is actually longer than the
2507 (formerly) longest thing.
2509 /* This lot will work for 64 bit *as long as* either
2510 either long is 64 bit
2511 or we can find both strtol/strtoq and strtoul/strtouq
2512 If not, we really should refuse to let the user use 64 bit IVs
2513 By "64 bit" I really mean IVs that don't get preserved by NVs
2514 It also should work for 128 bit IVs. Can any lend me a machine to
2517 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2518 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2519 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2520 ? sizeof(long) : sizeof (IV))*8-1))
2521 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2523 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2524 digit less (IV_MAX= 9223372036854775807,
2525 UV_MAX= 18446744073709551615) so be cautious */
2526 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2529 #ifdef USE_LOCALE_NUMERIC
2530 || (specialradix = IS_NUMERIC_RADIX(s))
2533 #ifdef USE_LOCALE_NUMERIC
2535 s += SvCUR(PL_numeric_radix);
2539 numtype |= IS_NUMBER_NOT_INT;
2540 while (isDIGIT(*s)) /* optional digits after the radix */
2545 #ifdef USE_LOCALE_NUMERIC
2546 || (specialradix = IS_NUMERIC_RADIX(s))
2549 #ifdef USE_LOCALE_NUMERIC
2551 s += SvCUR(PL_numeric_radix);
2555 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2556 /* no digits before the radix means we need digits after it */
2560 } while (isDIGIT(*s));
2565 else if (*s == 'I' || *s == 'i') {
2566 s++; if (*s != 'N' && *s != 'n') return 0;
2567 s++; if (*s != 'F' && *s != 'f') return 0;
2568 s++; if (*s == 'I' || *s == 'i') {
2569 s++; if (*s != 'N' && *s != 'n') return 0;
2570 s++; if (*s != 'I' && *s != 'i') return 0;
2571 s++; if (*s != 'T' && *s != 't') return 0;
2572 s++; if (*s != 'Y' && *s != 'y') return 0;
2581 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2582 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2584 /* we can have an optional exponent part */
2585 if (*s == 'e' || *s == 'E') {
2586 numtype &= IS_NUMBER_NEG;
2587 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2589 if (*s == '+' || *s == '-')
2594 } while (isDIGIT(*s));
2604 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2605 return IS_NUMBER_TO_INT_BY_ATOL;
2610 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2613 return sv_2pv(sv, &n_a);
2616 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2618 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2620 char *ptr = buf + TYPE_CHARS(UV);
2634 *--ptr = '0' + (uv % 10);
2643 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2648 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2649 char *tmpbuf = tbuf;
2655 if (SvGMAGICAL(sv)) {
2663 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2665 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2670 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2675 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2676 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2683 if (SvTHINKFIRST(sv)) {
2686 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2687 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2688 return SvPV(tmpstr,*lp);
2695 switch (SvTYPE(sv)) {
2697 if ( ((SvFLAGS(sv) &
2698 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2699 == (SVs_OBJECT|SVs_RMG))
2700 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2701 && (mg = mg_find(sv, 'r'))) {
2702 regexp *re = (regexp *)mg->mg_obj;
2705 char *fptr = "msix";
2710 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2712 while((ch = *fptr++)) {
2714 reflags[left++] = ch;
2717 reflags[right--] = ch;
2722 reflags[left] = '-';
2726 mg->mg_len = re->prelen + 4 + left;
2727 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2728 Copy("(?", mg->mg_ptr, 2, char);
2729 Copy(reflags, mg->mg_ptr+2, left, char);
2730 Copy(":", mg->mg_ptr+left+2, 1, char);
2731 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2732 mg->mg_ptr[mg->mg_len - 1] = ')';
2733 mg->mg_ptr[mg->mg_len] = 0;
2735 PL_reginterp_cnt += re->program[0].next_off;
2747 case SVt_PVBM: if (SvROK(sv))
2750 s = "SCALAR"; break;
2751 case SVt_PVLV: s = "LVALUE"; break;
2752 case SVt_PVAV: s = "ARRAY"; break;
2753 case SVt_PVHV: s = "HASH"; break;
2754 case SVt_PVCV: s = "CODE"; break;
2755 case SVt_PVGV: s = "GLOB"; break;
2756 case SVt_PVFM: s = "FORMAT"; break;
2757 case SVt_PVIO: s = "IO"; break;
2758 default: s = "UNKNOWN"; break;
2762 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2765 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2771 if (SvREADONLY(sv) && !SvOK(sv)) {
2772 if (ckWARN(WARN_UNINITIALIZED))
2778 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2779 /* I'm assuming that if both IV and NV are equally valid then
2780 converting the IV is going to be more efficient */
2781 U32 isIOK = SvIOK(sv);
2782 U32 isUIOK = SvIsUV(sv);
2783 char buf[TYPE_CHARS(UV)];
2786 if (SvTYPE(sv) < SVt_PVIV)
2787 sv_upgrade(sv, SVt_PVIV);
2789 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2791 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2792 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2793 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2794 SvCUR_set(sv, ebuf - ptr);
2804 else if (SvNOKp(sv)) {
2805 if (SvTYPE(sv) < SVt_PVNV)
2806 sv_upgrade(sv, SVt_PVNV);
2807 /* The +20 is pure guesswork. Configure test needed. --jhi */
2808 SvGROW(sv, NV_DIG + 20);
2810 olderrno = errno; /* some Xenix systems wipe out errno here */
2812 if (SvNVX(sv) == 0.0)
2813 (void)strcpy(s,"0");
2817 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2820 #ifdef FIXNEGATIVEZERO
2821 if (*s == '-' && s[1] == '0' && !s[2])
2831 if (ckWARN(WARN_UNINITIALIZED)
2832 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2835 if (SvTYPE(sv) < SVt_PV)
2836 /* Typically the caller expects that sv_any is not NULL now. */
2837 sv_upgrade(sv, SVt_PV);
2840 *lp = s - SvPVX(sv);
2843 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2844 PTR2UV(sv),SvPVX(sv)));
2848 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2849 /* Sneaky stuff here */
2853 tsv = newSVpv(tmpbuf, 0);
2869 len = strlen(tmpbuf);
2871 #ifdef FIXNEGATIVEZERO
2872 if (len == 2 && t[0] == '-' && t[1] == '0') {
2877 (void)SvUPGRADE(sv, SVt_PV);
2879 s = SvGROW(sv, len + 1);
2888 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2891 return sv_2pvbyte(sv, &n_a);
2895 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2897 sv_utf8_downgrade(sv,0);
2898 return SvPV(sv,*lp);
2902 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2905 return sv_2pvutf8(sv, &n_a);
2909 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2911 sv_utf8_upgrade(sv);
2912 return SvPV(sv,*lp);
2915 /* This function is only called on magical items */
2917 Perl_sv_2bool(pTHX_ register SV *sv)
2926 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2927 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
2928 return SvTRUE(tmpsv);
2929 return SvRV(sv) != 0;
2932 register XPV* Xpvtmp;
2933 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2934 (*Xpvtmp->xpv_pv > '0' ||
2935 Xpvtmp->xpv_cur > 1 ||
2936 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2943 return SvIVX(sv) != 0;
2946 return SvNVX(sv) != 0.0;
2954 =for apidoc sv_utf8_upgrade
2956 Convert the PV of an SV to its UTF8-encoded form.
2957 Forces the SV to string form it it is not already.
2958 Always sets the SvUTF8 flag to avoid future validity checks even
2959 if all the bytes have hibit clear.
2965 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2975 (void) sv_2pv(sv,&len);
2983 if (SvREADONLY(sv) && SvFAKE(sv)) {
2984 sv_force_normal(sv);
2987 /* This function could be much more efficient if we had a FLAG in SVs
2988 * to signal if there are any hibit chars in the PV.
2989 * Given that there isn't make loop fast as possible
2991 s = (U8 *) SvPVX(sv);
2992 e = (U8 *) SvEND(sv);
2996 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3002 len = SvCUR(sv) + 1; /* Plus the \0 */
3003 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3004 SvCUR(sv) = len - 1;
3006 Safefree(s); /* No longer using what was there before. */
3007 SvLEN(sv) = len; /* No longer know the real size. */
3009 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3015 =for apidoc sv_utf8_downgrade
3017 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3018 This may not be possible if the PV contains non-byte encoding characters;
3019 if this is the case, either returns false or, if C<fail_ok> is not
3026 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3028 if (SvPOK(sv) && SvUTF8(sv)) {
3033 if (SvREADONLY(sv) && SvFAKE(sv))
3034 sv_force_normal(sv);
3035 s = (U8 *) SvPV(sv, len);
3036 if (!utf8_to_bytes(s, &len)) {
3039 #ifdef USE_BYTES_DOWNGRADES
3042 U8 *e = (U8 *) SvEND(sv);
3045 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3046 if (first && ch > 255) {
3048 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3049 PL_op_desc[PL_op->op_type]);
3051 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3058 len = (d - (U8 *) SvPVX(sv));
3063 Perl_croak(aTHX_ "Wide character in %s",
3064 PL_op_desc[PL_op->op_type]);
3066 Perl_croak(aTHX_ "Wide character");
3077 =for apidoc sv_utf8_encode
3079 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3080 flag so that it looks like octets again. Used as a building block
3081 for encode_utf8 in Encode.xs
3087 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3089 (void) sv_utf8_upgrade(sv);
3094 =for apidoc sv_utf8_decode
3096 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3097 turn of SvUTF8 if needed so that we see characters. Used as a building block
3098 for decode_utf8 in Encode.xs
3106 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3112 /* The octets may have got themselves encoded - get them back as bytes */
3113 if (!sv_utf8_downgrade(sv, TRUE))
3116 /* it is actually just a matter of turning the utf8 flag on, but
3117 * we want to make sure everything inside is valid utf8 first.
3119 c = (U8 *) SvPVX(sv);
3120 if (!is_utf8_string(c, SvCUR(sv)+1))
3122 e = (U8 *) SvEND(sv);
3125 if (!UTF8_IS_INVARIANT(ch)) {
3135 /* Note: sv_setsv() should not be called with a source string that needs
3136 * to be reused, since it may destroy the source string if it is marked
3141 =for apidoc sv_setsv
3143 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3144 The source SV may be destroyed if it is mortal. Does not handle 'set'
3145 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3152 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3154 register U32 sflags;
3160 SV_CHECK_THINKFIRST(dstr);
3162 sstr = &PL_sv_undef;
3163 stype = SvTYPE(sstr);
3164 dtype = SvTYPE(dstr);
3168 /* There's a lot of redundancy below but we're going for speed here */
3173 if (dtype != SVt_PVGV) {
3174 (void)SvOK_off(dstr);
3182 sv_upgrade(dstr, SVt_IV);
3185 sv_upgrade(dstr, SVt_PVNV);
3189 sv_upgrade(dstr, SVt_PVIV);
3192 (void)SvIOK_only(dstr);
3193 SvIVX(dstr) = SvIVX(sstr);
3196 if (SvTAINTED(sstr))
3207 sv_upgrade(dstr, SVt_NV);
3212 sv_upgrade(dstr, SVt_PVNV);
3215 SvNVX(dstr) = SvNVX(sstr);
3216 (void)SvNOK_only(dstr);
3217 if (SvTAINTED(sstr))
3225 sv_upgrade(dstr, SVt_RV);
3226 else if (dtype == SVt_PVGV &&
3227 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3230 if (GvIMPORTED(dstr) != GVf_IMPORTED
3231 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3233 GvIMPORTED_on(dstr);
3244 sv_upgrade(dstr, SVt_PV);
3247 if (dtype < SVt_PVIV)
3248 sv_upgrade(dstr, SVt_PVIV);
3251 if (dtype < SVt_PVNV)
3252 sv_upgrade(dstr, SVt_PVNV);
3259 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3260 PL_op_name[PL_op->op_type]);
3262 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3266 if (dtype <= SVt_PVGV) {
3268 if (dtype != SVt_PVGV) {
3269 char *name = GvNAME(sstr);
3270 STRLEN len = GvNAMELEN(sstr);
3271 sv_upgrade(dstr, SVt_PVGV);
3272 sv_magic(dstr, dstr, '*', Nullch, 0);
3273 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3274 GvNAME(dstr) = savepvn(name, len);
3275 GvNAMELEN(dstr) = len;
3276 SvFAKE_on(dstr); /* can coerce to non-glob */
3278 /* ahem, death to those who redefine active sort subs */
3279 else if (PL_curstackinfo->si_type == PERLSI_SORT
3280 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3281 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3284 #ifdef GV_SHARED_CHECK
3285 if (GvSHARED((GV*)dstr)) {
3286 Perl_croak(aTHX_ PL_no_modify);
3290 (void)SvOK_off(dstr);
3291 GvINTRO_off(dstr); /* one-shot flag */
3293 GvGP(dstr) = gp_ref(GvGP(sstr));
3294 if (SvTAINTED(sstr))
3296 if (GvIMPORTED(dstr) != GVf_IMPORTED
3297 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3299 GvIMPORTED_on(dstr);
3307 if (SvGMAGICAL(sstr)) {
3309 if (SvTYPE(sstr) != stype) {
3310 stype = SvTYPE(sstr);
3311 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3315 if (stype == SVt_PVLV)
3316 (void)SvUPGRADE(dstr, SVt_PVNV);
3318 (void)SvUPGRADE(dstr, stype);
3321 sflags = SvFLAGS(sstr);
3323 if (sflags & SVf_ROK) {
3324 if (dtype >= SVt_PV) {
3325 if (dtype == SVt_PVGV) {
3326 SV *sref = SvREFCNT_inc(SvRV(sstr));
3328 int intro = GvINTRO(dstr);
3330 #ifdef GV_SHARED_CHECK
3331 if (GvSHARED((GV*)dstr)) {
3332 Perl_croak(aTHX_ PL_no_modify);
3339 GvINTRO_off(dstr); /* one-shot flag */
3340 Newz(602,gp, 1, GP);
3341 GvGP(dstr) = gp_ref(gp);
3342 GvSV(dstr) = NEWSV(72,0);
3343 GvLINE(dstr) = CopLINE(PL_curcop);
3344 GvEGV(dstr) = (GV*)dstr;
3347 switch (SvTYPE(sref)) {
3350 SAVESPTR(GvAV(dstr));
3352 dref = (SV*)GvAV(dstr);
3353 GvAV(dstr) = (AV*)sref;
3354 if (!GvIMPORTED_AV(dstr)
3355 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3357 GvIMPORTED_AV_on(dstr);
3362 SAVESPTR(GvHV(dstr));
3364 dref = (SV*)GvHV(dstr);
3365 GvHV(dstr) = (HV*)sref;
3366 if (!GvIMPORTED_HV(dstr)
3367 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3369 GvIMPORTED_HV_on(dstr);
3374 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3375 SvREFCNT_dec(GvCV(dstr));
3376 GvCV(dstr) = Nullcv;
3377 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3378 PL_sub_generation++;
3380 SAVESPTR(GvCV(dstr));
3383 dref = (SV*)GvCV(dstr);
3384 if (GvCV(dstr) != (CV*)sref) {
3385 CV* cv = GvCV(dstr);
3387 if (!GvCVGEN((GV*)dstr) &&
3388 (CvROOT(cv) || CvXSUB(cv)))
3390 /* ahem, death to those who redefine
3391 * active sort subs */
3392 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3393 PL_sortcop == CvSTART(cv))
3395 "Can't redefine active sort subroutine %s",
3396 GvENAME((GV*)dstr));
3397 /* Redefining a sub - warning is mandatory if
3398 it was a const and its value changed. */
3399 if (ckWARN(WARN_REDEFINE)
3401 && (!CvCONST((CV*)sref)
3402 || sv_cmp(cv_const_sv(cv),
3403 cv_const_sv((CV*)sref)))))
3405 Perl_warner(aTHX_ WARN_REDEFINE,
3407 ? "Constant subroutine %s redefined"
3408 : "Subroutine %s redefined",
3409 GvENAME((GV*)dstr));
3412 cv_ckproto(cv, (GV*)dstr,
3413 SvPOK(sref) ? SvPVX(sref) : Nullch);
3415 GvCV(dstr) = (CV*)sref;
3416 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3417 GvASSUMECV_on(dstr);
3418 PL_sub_generation++;
3420 if (!GvIMPORTED_CV(dstr)
3421 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3423 GvIMPORTED_CV_on(dstr);
3428 SAVESPTR(GvIOp(dstr));
3430 dref = (SV*)GvIOp(dstr);
3431 GvIOp(dstr) = (IO*)sref;
3435 SAVESPTR(GvFORM(dstr));
3437 dref = (SV*)GvFORM(dstr);
3438 GvFORM(dstr) = (CV*)sref;
3442 SAVESPTR(GvSV(dstr));
3444 dref = (SV*)GvSV(dstr);
3446 if (!GvIMPORTED_SV(dstr)
3447 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3449 GvIMPORTED_SV_on(dstr);
3457 if (SvTAINTED(sstr))
3462 (void)SvOOK_off(dstr); /* backoff */
3464 Safefree(SvPVX(dstr));
3465 SvLEN(dstr)=SvCUR(dstr)=0;
3468 (void)SvOK_off(dstr);
3469 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3471 if (sflags & SVp_NOK) {
3473 /* Only set the public OK flag if the source has public OK. */
3474 if (sflags & SVf_NOK)
3475 SvFLAGS(dstr) |= SVf_NOK;
3476 SvNVX(dstr) = SvNVX(sstr);
3478 if (sflags & SVp_IOK) {
3479 (void)SvIOKp_on(dstr);
3480 if (sflags & SVf_IOK)
3481 SvFLAGS(dstr) |= SVf_IOK;
3482 if (sflags & SVf_IVisUV)
3484 SvIVX(dstr) = SvIVX(sstr);
3486 if (SvAMAGIC(sstr)) {
3490 else if (sflags & SVp_POK) {
3493 * Check to see if we can just swipe the string. If so, it's a
3494 * possible small lose on short strings, but a big win on long ones.
3495 * It might even be a win on short strings if SvPVX(dstr)
3496 * has to be allocated and SvPVX(sstr) has to be freed.
3499 if (SvTEMP(sstr) && /* slated for free anyway? */
3500 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3501 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3502 SvLEN(sstr) && /* and really is a string */
3503 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3505 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3507 SvFLAGS(dstr) &= ~SVf_OOK;
3508 Safefree(SvPVX(dstr) - SvIVX(dstr));
3510 else if (SvLEN(dstr))
3511 Safefree(SvPVX(dstr));
3513 (void)SvPOK_only(dstr);
3514 SvPV_set(dstr, SvPVX(sstr));
3515 SvLEN_set(dstr, SvLEN(sstr));
3516 SvCUR_set(dstr, SvCUR(sstr));
3519 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3520 SvPV_set(sstr, Nullch);
3525 else { /* have to copy actual string */
3526 STRLEN len = SvCUR(sstr);
3528 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3529 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3530 SvCUR_set(dstr, len);
3531 *SvEND(dstr) = '\0';
3532 (void)SvPOK_only(dstr);
3534 if (sflags & SVf_UTF8)
3537 if (sflags & SVp_NOK) {
3539 if (sflags & SVf_NOK)
3540 SvFLAGS(dstr) |= SVf_NOK;
3541 SvNVX(dstr) = SvNVX(sstr);
3543 if (sflags & SVp_IOK) {
3544 (void)SvIOKp_on(dstr);
3545 if (sflags & SVf_IOK)
3546 SvFLAGS(dstr) |= SVf_IOK;
3547 if (sflags & SVf_IVisUV)
3549 SvIVX(dstr) = SvIVX(sstr);
3552 else if (sflags & SVp_IOK) {
3553 if (sflags & SVf_IOK)
3554 (void)SvIOK_only(dstr);
3556 (void)SvOK_off(dstr);
3557 (void)SvIOKp_on(dstr);
3559 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3560 if (sflags & SVf_IVisUV)
3562 SvIVX(dstr) = SvIVX(sstr);
3563 if (sflags & SVp_NOK) {
3564 if (sflags & SVf_NOK)
3565 (void)SvNOK_on(dstr);
3567 (void)SvNOKp_on(dstr);
3568 SvNVX(dstr) = SvNVX(sstr);
3571 else if (sflags & SVp_NOK) {
3572 if (sflags & SVf_NOK)
3573 (void)SvNOK_only(dstr);
3575 (void)SvOK_off(dstr);
3578 SvNVX(dstr) = SvNVX(sstr);
3581 if (dtype == SVt_PVGV) {
3582 if (ckWARN(WARN_MISC))
3583 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3586 (void)SvOK_off(dstr);
3588 if (SvTAINTED(sstr))
3593 =for apidoc sv_setsv_mg
3595 Like C<sv_setsv>, but also handles 'set' magic.
3601 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3603 sv_setsv(dstr,sstr);
3608 =for apidoc sv_setpvn
3610 Copies a string into an SV. The C<len> parameter indicates the number of
3611 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3617 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3619 register char *dptr;
3621 SV_CHECK_THINKFIRST(sv);
3627 /* len is STRLEN which is unsigned, need to copy to signed */
3631 (void)SvUPGRADE(sv, SVt_PV);
3633 SvGROW(sv, len + 1);
3635 Move(ptr,dptr,len,char);
3638 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3643 =for apidoc sv_setpvn_mg
3645 Like C<sv_setpvn>, but also handles 'set' magic.
3651 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3653 sv_setpvn(sv,ptr,len);
3658 =for apidoc sv_setpv
3660 Copies a string into an SV. The string must be null-terminated. Does not
3661 handle 'set' magic. See C<sv_setpv_mg>.
3667 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3669 register STRLEN len;
3671 SV_CHECK_THINKFIRST(sv);
3677 (void)SvUPGRADE(sv, SVt_PV);
3679 SvGROW(sv, len + 1);
3680 Move(ptr,SvPVX(sv),len+1,char);
3682 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3687 =for apidoc sv_setpv_mg
3689 Like C<sv_setpv>, but also handles 'set' magic.
3695 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3702 =for apidoc sv_usepvn
3704 Tells an SV to use C<ptr> to find its string value. Normally the string is
3705 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3706 The C<ptr> should point to memory that was allocated by C<malloc>. The
3707 string length, C<len>, must be supplied. This function will realloc the
3708 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3709 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3710 See C<sv_usepvn_mg>.
3716 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3718 SV_CHECK_THINKFIRST(sv);
3719 (void)SvUPGRADE(sv, SVt_PV);
3724 (void)SvOOK_off(sv);
3725 if (SvPVX(sv) && SvLEN(sv))
3726 Safefree(SvPVX(sv));
3727 Renew(ptr, len+1, char);
3730 SvLEN_set(sv, len+1);
3732 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3737 =for apidoc sv_usepvn_mg
3739 Like C<sv_usepvn>, but also handles 'set' magic.
3745 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3747 sv_usepvn(sv,ptr,len);
3752 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3754 if (SvREADONLY(sv)) {
3756 char *pvx = SvPVX(sv);
3757 STRLEN len = SvCUR(sv);
3758 U32 hash = SvUVX(sv);
3759 SvGROW(sv, len + 1);
3760 Move(pvx,SvPVX(sv),len,char);
3764 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3766 else if (PL_curcop != &PL_compiling)
3767 Perl_croak(aTHX_ PL_no_modify);
3770 sv_unref_flags(sv, flags);
3771 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3776 Perl_sv_force_normal(pTHX_ register SV *sv)
3778 sv_force_normal_flags(sv, 0);
3784 Efficient removal of characters from the beginning of the string buffer.
3785 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3786 the string buffer. The C<ptr> becomes the first character of the adjusted
3793 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3797 register STRLEN delta;
3799 if (!ptr || !SvPOKp(sv))
3801 SV_CHECK_THINKFIRST(sv);
3802 if (SvTYPE(sv) < SVt_PVIV)
3803 sv_upgrade(sv,SVt_PVIV);
3806 if (!SvLEN(sv)) { /* make copy of shared string */
3807 char *pvx = SvPVX(sv);
3808 STRLEN len = SvCUR(sv);
3809 SvGROW(sv, len + 1);
3810 Move(pvx,SvPVX(sv),len,char);
3814 SvFLAGS(sv) |= SVf_OOK;
3816 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3817 delta = ptr - SvPVX(sv);
3825 =for apidoc sv_catpvn
3827 Concatenates the string onto the end of the string which is in the SV. The
3828 C<len> indicates number of bytes to copy. If the SV has the UTF8
3829 status set, then the bytes appended should be valid UTF8.
3830 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3836 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3841 junk = SvPV_force(sv, tlen);
3842 SvGROW(sv, tlen + len + 1);
3845 Move(ptr,SvPVX(sv)+tlen,len,char);
3848 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3853 =for apidoc sv_catpvn_mg
3855 Like C<sv_catpvn>, but also handles 'set' magic.
3861 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3863 sv_catpvn(sv,ptr,len);
3868 =for apidoc sv_catsv
3870 Concatenates the string from SV C<ssv> onto the end of the string in
3871 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3872 not 'set' magic. See C<sv_catsv_mg>.
3877 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3883 if ((spv = SvPV(ssv, slen))) {
3884 bool dutf8 = DO_UTF8(dsv);
3885 bool sutf8 = DO_UTF8(ssv);
3888 sv_catpvn(dsv,spv,slen);
3891 /* Not modifying source SV, so taking a temporary copy. */
3892 SV* csv = sv_2mortal(newSVsv(ssv));
3896 sv_utf8_upgrade(csv);
3897 cpv = SvPV(csv,clen);
3898 sv_catpvn(dsv,cpv,clen);
3901 sv_utf8_upgrade(dsv);
3902 sv_catpvn(dsv,spv,slen);
3903 SvUTF8_on(dsv); /* If dsv has no wide characters. */
3910 =for apidoc sv_catsv_mg
3912 Like C<sv_catsv>, but also handles 'set' magic.
3918 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3925 =for apidoc sv_catpv
3927 Concatenates the string onto the end of the string which is in the SV.
3928 If the SV has the UTF8 status set, then the bytes appended should be
3929 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3934 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3936 register STRLEN len;
3942 junk = SvPV_force(sv, tlen);
3944 SvGROW(sv, tlen + len + 1);
3947 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3949 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3954 =for apidoc sv_catpv_mg
3956 Like C<sv_catpv>, but also handles 'set' magic.
3962 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3969 Perl_newSV(pTHX_ STRLEN len)
3975 sv_upgrade(sv, SVt_PV);
3976 SvGROW(sv, len + 1);
3981 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3984 =for apidoc sv_magic
3986 Adds magic to an SV.
3992 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3996 if (SvREADONLY(sv)) {
3997 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3998 Perl_croak(aTHX_ PL_no_modify);
4000 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
4001 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4008 (void)SvUPGRADE(sv, SVt_PVMG);
4010 Newz(702,mg, 1, MAGIC);
4011 mg->mg_moremagic = SvMAGIC(sv);
4014 /* Some magic sontains a reference loop, where the sv and object refer to
4015 each other. To prevent a avoid a reference loop that would prevent such
4016 objects being freed, we look for such loops and if we find one we avoid
4017 incrementing the object refcount. */
4018 if (!obj || obj == sv || how == '#' || how == 'r' ||
4019 (SvTYPE(obj) == SVt_PVGV &&
4020 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4021 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4022 GvFORM(obj) == (CV*)sv)))
4027 mg->mg_obj = SvREFCNT_inc(obj);
4028 mg->mg_flags |= MGf_REFCOUNTED;
4031 mg->mg_len = namlen;
4034 mg->mg_ptr = savepvn(name, namlen);
4035 else if (namlen == HEf_SVKEY)
4036 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4041 mg->mg_virtual = &PL_vtbl_sv;
4044 mg->mg_virtual = &PL_vtbl_amagic;
4047 mg->mg_virtual = &PL_vtbl_amagicelem;
4050 mg->mg_virtual = &PL_vtbl_ovrld;
4053 mg->mg_virtual = &PL_vtbl_bm;
4056 mg->mg_virtual = &PL_vtbl_regdata;
4059 mg->mg_virtual = &PL_vtbl_regdatum;
4062 mg->mg_virtual = &PL_vtbl_env;
4065 mg->mg_virtual = &PL_vtbl_fm;
4068 mg->mg_virtual = &PL_vtbl_envelem;
4071 mg->mg_virtual = &PL_vtbl_mglob;
4074 mg->mg_virtual = &PL_vtbl_isa;
4077 mg->mg_virtual = &PL_vtbl_isaelem;
4080 mg->mg_virtual = &PL_vtbl_nkeys;
4087 mg->mg_virtual = &PL_vtbl_dbline;
4091 mg->mg_virtual = &PL_vtbl_mutex;
4093 #endif /* USE_THREADS */
4094 #ifdef USE_LOCALE_COLLATE
4096 mg->mg_virtual = &PL_vtbl_collxfrm;
4098 #endif /* USE_LOCALE_COLLATE */
4100 mg->mg_virtual = &PL_vtbl_pack;
4104 mg->mg_virtual = &PL_vtbl_packelem;
4107 mg->mg_virtual = &PL_vtbl_regexp;
4110 mg->mg_virtual = &PL_vtbl_sig;
4113 mg->mg_virtual = &PL_vtbl_sigelem;
4116 mg->mg_virtual = &PL_vtbl_taint;
4120 mg->mg_virtual = &PL_vtbl_uvar;
4123 mg->mg_virtual = &PL_vtbl_vec;
4126 mg->mg_virtual = &PL_vtbl_substr;
4129 mg->mg_virtual = &PL_vtbl_defelem;
4132 mg->mg_virtual = &PL_vtbl_glob;
4135 mg->mg_virtual = &PL_vtbl_arylen;
4138 mg->mg_virtual = &PL_vtbl_pos;
4141 mg->mg_virtual = &PL_vtbl_backref;
4143 case '~': /* Reserved for use by extensions not perl internals. */
4144 /* Useful for attaching extension internal data to perl vars. */
4145 /* Note that multiple extensions may clash if magical scalars */
4146 /* etc holding private data from one are passed to another. */
4150 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4154 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4158 =for apidoc sv_unmagic
4160 Removes magic from an SV.
4166 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4170 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4173 for (mg = *mgp; mg; mg = *mgp) {
4174 if (mg->mg_type == type) {
4175 MGVTBL* vtbl = mg->mg_virtual;
4176 *mgp = mg->mg_moremagic;
4177 if (vtbl && vtbl->svt_free)
4178 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4179 if (mg->mg_ptr && mg->mg_type != 'g') {
4180 if (mg->mg_len >= 0)
4181 Safefree(mg->mg_ptr);
4182 else if (mg->mg_len == HEf_SVKEY)
4183 SvREFCNT_dec((SV*)mg->mg_ptr);
4185 if (mg->mg_flags & MGf_REFCOUNTED)
4186 SvREFCNT_dec(mg->mg_obj);
4190 mgp = &mg->mg_moremagic;
4194 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4201 =for apidoc sv_rvweaken
4209 Perl_sv_rvweaken(pTHX_ SV *sv)
4212 if (!SvOK(sv)) /* let undefs pass */
4215 Perl_croak(aTHX_ "Can't weaken a nonreference");
4216 else if (SvWEAKREF(sv)) {
4217 if (ckWARN(WARN_MISC))
4218 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4222 sv_add_backref(tsv, sv);
4229 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4233 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4234 av = (AV*)mg->mg_obj;
4237 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4238 SvREFCNT_dec(av); /* for sv_magic */
4244 S_sv_del_backref(pTHX_ SV *sv)
4251 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4252 Perl_croak(aTHX_ "panic: del_backref");
4253 av = (AV *)mg->mg_obj;
4258 svp[i] = &PL_sv_undef; /* XXX */
4265 =for apidoc sv_insert
4267 Inserts a string at the specified offset/length within the SV. Similar to
4268 the Perl substr() function.
4274 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4278 register char *midend;
4279 register char *bigend;
4285 Perl_croak(aTHX_ "Can't modify non-existent substring");
4286 SvPV_force(bigstr, curlen);
4287 (void)SvPOK_only_UTF8(bigstr);
4288 if (offset + len > curlen) {
4289 SvGROW(bigstr, offset+len+1);
4290 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4291 SvCUR_set(bigstr, offset+len);
4295 i = littlelen - len;
4296 if (i > 0) { /* string might grow */
4297 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4298 mid = big + offset + len;
4299 midend = bigend = big + SvCUR(bigstr);
4302 while (midend > mid) /* shove everything down */
4303 *--bigend = *--midend;
4304 Move(little,big+offset,littlelen,char);
4310 Move(little,SvPVX(bigstr)+offset,len,char);
4315 big = SvPVX(bigstr);
4318 bigend = big + SvCUR(bigstr);
4320 if (midend > bigend)
4321 Perl_croak(aTHX_ "panic: sv_insert");
4323 if (mid - big > bigend - midend) { /* faster to shorten from end */
4325 Move(little, mid, littlelen,char);
4328 i = bigend - midend;
4330 Move(midend, mid, i,char);
4334 SvCUR_set(bigstr, mid - big);
4337 else if ((i = mid - big)) { /* faster from front */
4338 midend -= littlelen;
4340 sv_chop(bigstr,midend-i);
4345 Move(little, mid, littlelen,char);
4347 else if (littlelen) {
4348 midend -= littlelen;
4349 sv_chop(bigstr,midend);
4350 Move(little,midend,littlelen,char);
4353 sv_chop(bigstr,midend);
4359 =for apidoc sv_replace
4361 Make the first argument a copy of the second, then delete the original.
4367 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4369 U32 refcnt = SvREFCNT(sv);
4370 SV_CHECK_THINKFIRST(sv);
4371 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4372 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4373 if (SvMAGICAL(sv)) {
4377 sv_upgrade(nsv, SVt_PVMG);
4378 SvMAGIC(nsv) = SvMAGIC(sv);
4379 SvFLAGS(nsv) |= SvMAGICAL(sv);
4385 assert(!SvREFCNT(sv));
4386 StructCopy(nsv,sv,SV);
4387 SvREFCNT(sv) = refcnt;
4388 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4393 =for apidoc sv_clear
4395 Clear an SV, making it empty. Does not free the memory used by the SV
4402 Perl_sv_clear(pTHX_ register SV *sv)
4406 assert(SvREFCNT(sv) == 0);
4409 if (PL_defstash) { /* Still have a symbol table? */
4414 Zero(&tmpref, 1, SV);
4415 sv_upgrade(&tmpref, SVt_RV);
4417 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4418 SvREFCNT(&tmpref) = 1;
4421 stash = SvSTASH(sv);
4422 destructor = StashHANDLER(stash,DESTROY);
4425 PUSHSTACKi(PERLSI_DESTROY);
4426 SvRV(&tmpref) = SvREFCNT_inc(sv);
4431 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4437 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4439 del_XRV(SvANY(&tmpref));
4442 if (PL_in_clean_objs)
4443 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4445 /* DESTROY gave object new lease on life */
4451 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4452 SvOBJECT_off(sv); /* Curse the object. */
4453 if (SvTYPE(sv) != SVt_PVIO)
4454 --PL_sv_objcount; /* XXX Might want something more general */
4457 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4460 switch (SvTYPE(sv)) {
4463 IoIFP(sv) != PerlIO_stdin() &&
4464 IoIFP(sv) != PerlIO_stdout() &&
4465 IoIFP(sv) != PerlIO_stderr())
4467 io_close((IO*)sv, FALSE);
4469 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4470 PerlDir_close(IoDIRP(sv));
4471 IoDIRP(sv) = (DIR*)NULL;
4472 Safefree(IoTOP_NAME(sv));
4473 Safefree(IoFMT_NAME(sv));
4474 Safefree(IoBOTTOM_NAME(sv));
4489 SvREFCNT_dec(LvTARG(sv));
4493 Safefree(GvNAME(sv));
4494 /* cannot decrease stash refcount yet, as we might recursively delete
4495 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4496 of stash until current sv is completely gone.
4497 -- JohnPC, 27 Mar 1998 */
4498 stash = GvSTASH(sv);
4504 (void)SvOOK_off(sv);
4512 SvREFCNT_dec(SvRV(sv));
4514 else if (SvPVX(sv) && SvLEN(sv))
4515 Safefree(SvPVX(sv));
4516 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4517 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4529 switch (SvTYPE(sv)) {
4545 del_XPVIV(SvANY(sv));
4548 del_XPVNV(SvANY(sv));
4551 del_XPVMG(SvANY(sv));
4554 del_XPVLV(SvANY(sv));
4557 del_XPVAV(SvANY(sv));
4560 del_XPVHV(SvANY(sv));
4563 del_XPVCV(SvANY(sv));
4566 del_XPVGV(SvANY(sv));
4567 /* code duplication for increased performance. */
4568 SvFLAGS(sv) &= SVf_BREAK;
4569 SvFLAGS(sv) |= SVTYPEMASK;
4570 /* decrease refcount of the stash that owns this GV, if any */
4572 SvREFCNT_dec(stash);
4573 return; /* not break, SvFLAGS reset already happened */
4575 del_XPVBM(SvANY(sv));
4578 del_XPVFM(SvANY(sv));
4581 del_XPVIO(SvANY(sv));
4584 SvFLAGS(sv) &= SVf_BREAK;
4585 SvFLAGS(sv) |= SVTYPEMASK;
4589 Perl_sv_newref(pTHX_ SV *sv)
4592 ATOMIC_INC(SvREFCNT(sv));
4599 Free the memory used by an SV.
4605 Perl_sv_free(pTHX_ SV *sv)
4607 int refcount_is_zero;
4611 if (SvREFCNT(sv) == 0) {
4612 if (SvFLAGS(sv) & SVf_BREAK)
4614 if (PL_in_clean_all) /* All is fair */
4616 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4617 /* make sure SvREFCNT(sv)==0 happens very seldom */
4618 SvREFCNT(sv) = (~(U32)0)/2;
4621 if (ckWARN_d(WARN_INTERNAL))
4622 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4625 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4626 if (!refcount_is_zero)
4630 if (ckWARN_d(WARN_DEBUGGING))
4631 Perl_warner(aTHX_ WARN_DEBUGGING,
4632 "Attempt to free temp prematurely: SV 0x%"UVxf,
4637 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4638 /* make sure SvREFCNT(sv)==0 happens very seldom */
4639 SvREFCNT(sv) = (~(U32)0)/2;
4650 Returns the length of the string in the SV. See also C<SvCUR>.
4656 Perl_sv_len(pTHX_ register SV *sv)
4665 len = mg_length(sv);
4667 junk = SvPV(sv, len);
4672 =for apidoc sv_len_utf8
4674 Returns the number of characters in the string in an SV, counting wide
4675 UTF8 bytes as a single character.
4681 Perl_sv_len_utf8(pTHX_ register SV *sv)
4687 return mg_length(sv);
4691 U8 *s = (U8*)SvPV(sv, len);
4693 return Perl_utf8_length(aTHX_ s, s + len);
4698 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4703 I32 uoffset = *offsetp;
4709 start = s = (U8*)SvPV(sv, len);
4711 while (s < send && uoffset--)
4715 *offsetp = s - start;
4719 while (s < send && ulen--)
4729 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4738 s = (U8*)SvPV(sv, len);
4740 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4741 send = s + *offsetp;
4745 /* Call utf8n_to_uvchr() to validate the sequence */
4746 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4761 Returns a boolean indicating whether the strings in the two SVs are
4768 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4782 pv1 = SvPV(sv1, cur1);
4789 pv2 = SvPV(sv2, cur2);
4791 /* do not utf8ize the comparands as a side-effect */
4792 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4793 bool is_utf8 = TRUE;
4794 /* UTF-8ness differs */
4795 if (PL_hints & HINT_UTF8_DISTINCT)
4799 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4800 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4805 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4806 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4811 /* Downgrade not possible - cannot be eq */
4817 eq = memEQ(pv1, pv2, cur1);
4828 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4829 string in C<sv1> is less than, equal to, or greater than the string in
4836 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4841 bool pv1tmp = FALSE;
4842 bool pv2tmp = FALSE;
4849 pv1 = SvPV(sv1, cur1);
4856 pv2 = SvPV(sv2, cur2);
4858 /* do not utf8ize the comparands as a side-effect */
4859 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4860 if (PL_hints & HINT_UTF8_DISTINCT)
4861 return SvUTF8(sv1) ? 1 : -1;
4864 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4868 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4874 cmp = cur2 ? -1 : 0;
4878 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4881 cmp = retval < 0 ? -1 : 1;
4882 } else if (cur1 == cur2) {
4885 cmp = cur1 < cur2 ? -1 : 1;
4898 =for apidoc sv_cmp_locale
4900 Compares the strings in two SVs in a locale-aware manner. See
4907 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4909 #ifdef USE_LOCALE_COLLATE
4915 if (PL_collation_standard)
4919 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4921 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4923 if (!pv1 || !len1) {
4934 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4937 return retval < 0 ? -1 : 1;
4940 * When the result of collation is equality, that doesn't mean
4941 * that there are no differences -- some locales exclude some
4942 * characters from consideration. So to avoid false equalities,
4943 * we use the raw string as a tiebreaker.
4949 #endif /* USE_LOCALE_COLLATE */
4951 return sv_cmp(sv1, sv2);
4954 #ifdef USE_LOCALE_COLLATE
4956 * Any scalar variable may carry an 'o' magic that contains the
4957 * scalar data of the variable transformed to such a format that
4958 * a normal memory comparison can be used to compare the data
4959 * according to the locale settings.
4962 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4966 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4967 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4972 Safefree(mg->mg_ptr);
4974 if ((xf = mem_collxfrm(s, len, &xlen))) {
4975 if (SvREADONLY(sv)) {
4978 return xf + sizeof(PL_collation_ix);
4981 sv_magic(sv, 0, 'o', 0, 0);
4982 mg = mg_find(sv, 'o');
4995 if (mg && mg->mg_ptr) {
4997 return mg->mg_ptr + sizeof(PL_collation_ix);
5005 #endif /* USE_LOCALE_COLLATE */
5010 Get a line from the filehandle and store it into the SV, optionally
5011 appending to the currently-stored string.
5017 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5021 register STDCHAR rslast;
5022 register STDCHAR *bp;
5026 SV_CHECK_THINKFIRST(sv);
5027 (void)SvUPGRADE(sv, SVt_PV);
5031 if (RsSNARF(PL_rs)) {
5035 else if (RsRECORD(PL_rs)) {
5036 I32 recsize, bytesread;
5039 /* Grab the size of the record we're getting */
5040 recsize = SvIV(SvRV(PL_rs));
5041 (void)SvPOK_only(sv); /* Validate pointer */
5042 buffer = SvGROW(sv, recsize + 1);
5045 /* VMS wants read instead of fread, because fread doesn't respect */
5046 /* RMS record boundaries. This is not necessarily a good thing to be */
5047 /* doing, but we've got no other real choice */
5048 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5050 bytesread = PerlIO_read(fp, buffer, recsize);
5052 SvCUR_set(sv, bytesread);
5053 buffer[bytesread] = '\0';
5054 if (PerlIO_isutf8(fp))
5058 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5060 else if (RsPARA(PL_rs)) {
5065 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5066 if (PerlIO_isutf8(fp)) {
5067 rsptr = SvPVutf8(PL_rs, rslen);
5070 if (SvUTF8(PL_rs)) {
5071 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5072 Perl_croak(aTHX_ "Wide character in $/");
5075 rsptr = SvPV(PL_rs, rslen);
5079 rslast = rslen ? rsptr[rslen - 1] : '\0';
5081 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5082 do { /* to make sure file boundaries work right */
5085 i = PerlIO_getc(fp);
5089 PerlIO_ungetc(fp,i);
5095 /* See if we know enough about I/O mechanism to cheat it ! */
5097 /* This used to be #ifdef test - it is made run-time test for ease
5098 of abstracting out stdio interface. One call should be cheap
5099 enough here - and may even be a macro allowing compile
5103 if (PerlIO_fast_gets(fp)) {
5106 * We're going to steal some values from the stdio struct
5107 * and put EVERYTHING in the innermost loop into registers.
5109 register STDCHAR *ptr;
5113 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5114 /* An ungetc()d char is handled separately from the regular
5115 * buffer, so we getc() it back out and stuff it in the buffer.
5117 i = PerlIO_getc(fp);
5118 if (i == EOF) return 0;
5119 *(--((*fp)->_ptr)) = (unsigned char) i;
5123 /* Here is some breathtakingly efficient cheating */
5125 cnt = PerlIO_get_cnt(fp); /* get count into register */
5126 (void)SvPOK_only(sv); /* validate pointer */
5127 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5128 if (cnt > 80 && SvLEN(sv) > append) {
5129 shortbuffered = cnt - SvLEN(sv) + append + 1;
5130 cnt -= shortbuffered;
5134 /* remember that cnt can be negative */
5135 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5140 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5141 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5142 DEBUG_P(PerlIO_printf(Perl_debug_log,
5143 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5144 DEBUG_P(PerlIO_printf(Perl_debug_log,
5145 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5146 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5147 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5152 while (cnt > 0) { /* this | eat */
5154 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5155 goto thats_all_folks; /* screams | sed :-) */
5159 Copy(ptr, bp, cnt, char); /* this | eat */
5160 bp += cnt; /* screams | dust */
5161 ptr += cnt; /* louder | sed :-) */
5166 if (shortbuffered) { /* oh well, must extend */
5167 cnt = shortbuffered;
5169 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5171 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5172 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5176 DEBUG_P(PerlIO_printf(Perl_debug_log,
5177 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5178 PTR2UV(ptr),(long)cnt));
5179 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5180 DEBUG_P(PerlIO_printf(Perl_debug_log,
5181 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5182 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5183 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5184 /* This used to call 'filbuf' in stdio form, but as that behaves like
5185 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5186 another abstraction. */
5187 i = PerlIO_getc(fp); /* get more characters */
5188 DEBUG_P(PerlIO_printf(Perl_debug_log,
5189 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5190 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5191 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5192 cnt = PerlIO_get_cnt(fp);
5193 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5194 DEBUG_P(PerlIO_printf(Perl_debug_log,
5195 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5197 if (i == EOF) /* all done for ever? */
5198 goto thats_really_all_folks;
5200 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5202 SvGROW(sv, bpx + cnt + 2);
5203 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5205 *bp++ = i; /* store character from PerlIO_getc */
5207 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5208 goto thats_all_folks;
5212 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5213 memNE((char*)bp - rslen, rsptr, rslen))
5214 goto screamer; /* go back to the fray */
5215 thats_really_all_folks:
5217 cnt += shortbuffered;
5218 DEBUG_P(PerlIO_printf(Perl_debug_log,
5219 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5220 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5221 DEBUG_P(PerlIO_printf(Perl_debug_log,
5222 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5223 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5224 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5226 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5227 DEBUG_P(PerlIO_printf(Perl_debug_log,
5228 "Screamer: done, len=%ld, string=|%.*s|\n",
5229 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5234 /*The big, slow, and stupid way */
5237 /* Need to work around EPOC SDK features */
5238 /* On WINS: MS VC5 generates calls to _chkstk, */
5239 /* if a `large' stack frame is allocated */
5240 /* gcc on MARM does not generate calls like these */
5246 register STDCHAR *bpe = buf + sizeof(buf);
5248 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5249 ; /* keep reading */
5253 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5254 /* Accomodate broken VAXC compiler, which applies U8 cast to
5255 * both args of ?: operator, causing EOF to change into 255
5257 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5261 sv_catpvn(sv, (char *) buf, cnt);
5263 sv_setpvn(sv, (char *) buf, cnt);
5265 if (i != EOF && /* joy */
5267 SvCUR(sv) < rslen ||
5268 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5272 * If we're reading from a TTY and we get a short read,
5273 * indicating that the user hit his EOF character, we need
5274 * to notice it now, because if we try to read from the TTY
5275 * again, the EOF condition will disappear.
5277 * The comparison of cnt to sizeof(buf) is an optimization
5278 * that prevents unnecessary calls to feof().
5282 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5287 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5288 while (i != EOF) { /* to make sure file boundaries work right */
5289 i = PerlIO_getc(fp);
5291 PerlIO_ungetc(fp,i);
5297 if (PerlIO_isutf8(fp))
5302 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5309 Auto-increment of the value in the SV.
5315 Perl_sv_inc(pTHX_ register SV *sv)
5324 if (SvTHINKFIRST(sv)) {
5325 if (SvREADONLY(sv)) {
5326 if (PL_curcop != &PL_compiling)
5327 Perl_croak(aTHX_ PL_no_modify);
5331 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5333 i = PTR2IV(SvRV(sv));
5338 flags = SvFLAGS(sv);
5339 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5340 /* It's (privately or publicly) a float, but not tested as an
5341 integer, so test it to see. */
5343 flags = SvFLAGS(sv);
5345 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5346 /* It's publicly an integer, or privately an integer-not-float */
5349 if (SvUVX(sv) == UV_MAX)
5350 sv_setnv(sv, (NV)UV_MAX + 1.0);
5352 (void)SvIOK_only_UV(sv);
5355 if (SvIVX(sv) == IV_MAX)
5356 sv_setuv(sv, (UV)IV_MAX + 1);
5358 (void)SvIOK_only(sv);
5364 if (flags & SVp_NOK) {
5365 (void)SvNOK_only(sv);
5370 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5371 if ((flags & SVTYPEMASK) < SVt_PVIV)
5372 sv_upgrade(sv, SVt_IV);
5373 (void)SvIOK_only(sv);
5378 while (isALPHA(*d)) d++;
5379 while (isDIGIT(*d)) d++;
5381 #ifdef PERL_PRESERVE_IVUV
5382 /* Got to punt this an an integer if needs be, but we don't issue
5383 warnings. Probably ought to make the sv_iv_please() that does
5384 the conversion if possible, and silently. */
5385 I32 numtype = looks_like_number(sv);
5386 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5387 /* Need to try really hard to see if it's an integer.
5388 9.22337203685478e+18 is an integer.
5389 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5390 so $a="9.22337203685478e+18"; $a+0; $a++
5391 needs to be the same as $a="9.22337203685478e+18"; $a++
5398 /* sv_2iv *should* have made this an NV */
5399 if (flags & SVp_NOK) {
5400 (void)SvNOK_only(sv);
5404 /* I don't think we can get here. Maybe I should assert this
5405 And if we do get here I suspect that sv_setnv will croak. NWC
5407 #if defined(USE_LONG_DOUBLE)
5408 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",
5409 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5411 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5412 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5415 #endif /* PERL_PRESERVE_IVUV */
5416 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5420 while (d >= SvPVX(sv)) {
5428 /* MKS: The original code here died if letters weren't consecutive.
5429 * at least it didn't have to worry about non-C locales. The
5430 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5431 * arranged in order (although not consecutively) and that only
5432 * [A-Za-z] are accepted by isALPHA in the C locale.
5434 if (*d != 'z' && *d != 'Z') {
5435 do { ++*d; } while (!isALPHA(*d));
5438 *(d--) -= 'z' - 'a';
5443 *(d--) -= 'z' - 'a' + 1;
5447 /* oh,oh, the number grew */
5448 SvGROW(sv, SvCUR(sv) + 2);
5450 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5461 Auto-decrement of the value in the SV.
5467 Perl_sv_dec(pTHX_ register SV *sv)
5475 if (SvTHINKFIRST(sv)) {
5476 if (SvREADONLY(sv)) {
5477 if (PL_curcop != &PL_compiling)
5478 Perl_croak(aTHX_ PL_no_modify);
5482 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5484 i = PTR2IV(SvRV(sv));
5489 /* Unlike sv_inc we don't have to worry about string-never-numbers
5490 and keeping them magic. But we mustn't warn on punting */
5491 flags = SvFLAGS(sv);
5492 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5493 /* It's publicly an integer, or privately an integer-not-float */
5496 if (SvUVX(sv) == 0) {
5497 (void)SvIOK_only(sv);
5501 (void)SvIOK_only_UV(sv);
5505 if (SvIVX(sv) == IV_MIN)
5506 sv_setnv(sv, (NV)IV_MIN - 1.0);
5508 (void)SvIOK_only(sv);
5514 if (flags & SVp_NOK) {
5516 (void)SvNOK_only(sv);
5519 if (!(flags & SVp_POK)) {
5520 if ((flags & SVTYPEMASK) < SVt_PVNV)
5521 sv_upgrade(sv, SVt_NV);
5523 (void)SvNOK_only(sv);
5526 #ifdef PERL_PRESERVE_IVUV
5528 I32 numtype = looks_like_number(sv);
5529 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5530 /* Need to try really hard to see if it's an integer.
5531 9.22337203685478e+18 is an integer.
5532 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5533 so $a="9.22337203685478e+18"; $a+0; $a--
5534 needs to be the same as $a="9.22337203685478e+18"; $a--
5541 /* sv_2iv *should* have made this an NV */
5542 if (flags & SVp_NOK) {
5543 (void)SvNOK_only(sv);
5547 /* I don't think we can get here. Maybe I should assert this
5548 And if we do get here I suspect that sv_setnv will croak. NWC
5550 #if defined(USE_LONG_DOUBLE)
5551 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",
5552 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5554 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5555 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5559 #endif /* PERL_PRESERVE_IVUV */
5560 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5564 =for apidoc sv_mortalcopy
5566 Creates a new SV which is a copy of the original SV. The new SV is marked
5572 /* Make a string that will exist for the duration of the expression
5573 * evaluation. Actually, it may have to last longer than that, but
5574 * hopefully we won't free it until it has been assigned to a
5575 * permanent location. */
5578 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5583 sv_setsv(sv,oldstr);
5585 PL_tmps_stack[++PL_tmps_ix] = sv;
5591 =for apidoc sv_newmortal
5593 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5599 Perl_sv_newmortal(pTHX)
5604 SvFLAGS(sv) = SVs_TEMP;
5606 PL_tmps_stack[++PL_tmps_ix] = sv;
5611 =for apidoc sv_2mortal
5613 Marks an SV as mortal. The SV will be destroyed when the current context
5619 /* same thing without the copying */
5622 Perl_sv_2mortal(pTHX_ register SV *sv)
5626 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5629 PL_tmps_stack[++PL_tmps_ix] = sv;
5637 Creates a new SV and copies a string into it. The reference count for the
5638 SV is set to 1. If C<len> is zero, Perl will compute the length using
5639 strlen(). For efficiency, consider using C<newSVpvn> instead.
5645 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5652 sv_setpvn(sv,s,len);
5657 =for apidoc newSVpvn
5659 Creates a new SV and copies a string into it. The reference count for the
5660 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5661 string. You are responsible for ensuring that the source string is at least
5668 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5673 sv_setpvn(sv,s,len);
5678 =for apidoc newSVpvn_share
5680 Creates a new SV and populates it with a string from
5681 the string table. Turns on READONLY and FAKE.
5682 The idea here is that as string table is used for shared hash
5683 keys these strings will have SvPVX == HeKEY and hash lookup
5684 will avoid string compare.
5690 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5693 bool is_utf8 = FALSE;
5698 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5699 STRLEN tmplen = len;
5700 /* See the note in hv.c:hv_fetch() --jhi */
5701 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5705 PERL_HASH(hash, src, len);
5707 sv_upgrade(sv, SVt_PVIV);
5708 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5720 #if defined(PERL_IMPLICIT_CONTEXT)
5722 Perl_newSVpvf_nocontext(const char* pat, ...)
5727 va_start(args, pat);
5728 sv = vnewSVpvf(pat, &args);
5735 =for apidoc newSVpvf
5737 Creates a new SV an initialize it with the string formatted like
5744 Perl_newSVpvf(pTHX_ const char* pat, ...)
5748 va_start(args, pat);
5749 sv = vnewSVpvf(pat, &args);
5755 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5759 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5766 Creates a new SV and copies a floating point value into it.
5767 The reference count for the SV is set to 1.
5773 Perl_newSVnv(pTHX_ NV n)
5785 Creates a new SV and copies an integer into it. The reference count for the
5792 Perl_newSViv(pTHX_ IV i)
5804 Creates a new SV and copies an unsigned integer into it.
5805 The reference count for the SV is set to 1.
5811 Perl_newSVuv(pTHX_ UV u)
5821 =for apidoc newRV_noinc
5823 Creates an RV wrapper for an SV. The reference count for the original
5824 SV is B<not> incremented.
5830 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5835 sv_upgrade(sv, SVt_RV);
5842 /* newRV_inc is #defined to newRV in sv.h */
5844 Perl_newRV(pTHX_ SV *tmpRef)
5846 return newRV_noinc(SvREFCNT_inc(tmpRef));
5852 Creates a new SV which is an exact duplicate of the original SV.
5857 /* make an exact duplicate of old */
5860 Perl_newSVsv(pTHX_ register SV *old)
5866 if (SvTYPE(old) == SVTYPEMASK) {
5867 if (ckWARN_d(WARN_INTERNAL))
5868 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5883 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5891 char todo[PERL_UCHAR_MAX+1];
5896 if (!*s) { /* reset ?? searches */
5897 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5898 pm->op_pmdynflags &= ~PMdf_USED;
5903 /* reset variables */
5905 if (!HvARRAY(stash))
5908 Zero(todo, 256, char);
5910 i = (unsigned char)*s;
5914 max = (unsigned char)*s++;
5915 for ( ; i <= max; i++) {
5918 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5919 for (entry = HvARRAY(stash)[i];
5921 entry = HeNEXT(entry))
5923 if (!todo[(U8)*HeKEY(entry)])
5925 gv = (GV*)HeVAL(entry);
5927 if (SvTHINKFIRST(sv)) {
5928 if (!SvREADONLY(sv) && SvROK(sv))
5933 if (SvTYPE(sv) >= SVt_PV) {
5935 if (SvPVX(sv) != Nullch)
5942 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5944 #ifdef USE_ENVIRON_ARRAY
5946 environ[0] = Nullch;
5955 Perl_sv_2io(pTHX_ SV *sv)
5961 switch (SvTYPE(sv)) {
5969 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5973 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5975 return sv_2io(SvRV(sv));
5976 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5982 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5989 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5996 return *gvp = Nullgv, Nullcv;
5997 switch (SvTYPE(sv)) {
6016 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6017 tryAMAGICunDEREF(to_cv);
6020 if (SvTYPE(sv) == SVt_PVCV) {
6029 Perl_croak(aTHX_ "Not a subroutine reference");
6034 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6040 if (lref && !GvCVu(gv)) {
6043 tmpsv = NEWSV(704,0);
6044 gv_efullname3(tmpsv, gv, Nullch);
6045 /* XXX this is probably not what they think they're getting.
6046 * It has the same effect as "sub name;", i.e. just a forward
6048 newSUB(start_subparse(FALSE, 0),
6049 newSVOP(OP_CONST, 0, tmpsv),
6054 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6063 Returns true if the SV has a true value by Perl's rules.
6069 Perl_sv_true(pTHX_ register SV *sv)
6075 if ((tXpv = (XPV*)SvANY(sv)) &&
6076 (tXpv->xpv_cur > 1 ||
6077 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6084 return SvIVX(sv) != 0;
6087 return SvNVX(sv) != 0.0;
6089 return sv_2bool(sv);
6095 Perl_sv_iv(pTHX_ register SV *sv)
6099 return (IV)SvUVX(sv);
6106 Perl_sv_uv(pTHX_ register SV *sv)
6111 return (UV)SvIVX(sv);
6117 Perl_sv_nv(pTHX_ register SV *sv)
6125 Perl_sv_pv(pTHX_ SV *sv)
6132 return sv_2pv(sv, &n_a);
6136 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6142 return sv_2pv(sv, lp);
6146 =for apidoc sv_pvn_force
6148 Get a sensible string out of the SV somehow.
6154 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6158 if (SvTHINKFIRST(sv) && !SvROK(sv))
6159 sv_force_normal(sv);
6165 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6166 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6167 PL_op_name[PL_op->op_type]);
6171 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6176 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6177 SvGROW(sv, len + 1);
6178 Move(s,SvPVX(sv),len,char);
6183 SvPOK_on(sv); /* validate pointer */
6185 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6186 PTR2UV(sv),SvPVX(sv)));
6193 Perl_sv_pvbyte(pTHX_ SV *sv)
6195 sv_utf8_downgrade(sv,0);
6200 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6202 sv_utf8_downgrade(sv,0);
6203 return sv_pvn(sv,lp);
6207 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6209 sv_utf8_downgrade(sv,0);
6210 return sv_pvn_force(sv,lp);
6214 Perl_sv_pvutf8(pTHX_ SV *sv)
6216 sv_utf8_upgrade(sv);
6221 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6223 sv_utf8_upgrade(sv);
6224 return sv_pvn(sv,lp);
6228 =for apidoc sv_pvutf8n_force
6230 Get a sensible UTF8-encoded string out of the SV somehow. See
6237 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6239 sv_utf8_upgrade(sv);
6240 return sv_pvn_force(sv,lp);
6244 =for apidoc sv_reftype
6246 Returns a string describing what the SV is a reference to.
6252 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6254 if (ob && SvOBJECT(sv))
6255 return HvNAME(SvSTASH(sv));
6257 switch (SvTYPE(sv)) {
6271 case SVt_PVLV: return "LVALUE";
6272 case SVt_PVAV: return "ARRAY";
6273 case SVt_PVHV: return "HASH";
6274 case SVt_PVCV: return "CODE";
6275 case SVt_PVGV: return "GLOB";
6276 case SVt_PVFM: return "FORMAT";
6277 case SVt_PVIO: return "IO";
6278 default: return "UNKNOWN";
6284 =for apidoc sv_isobject
6286 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6287 object. If the SV is not an RV, or if the object is not blessed, then this
6294 Perl_sv_isobject(pTHX_ SV *sv)
6311 Returns a boolean indicating whether the SV is blessed into the specified
6312 class. This does not check for subtypes; use C<sv_derived_from> to verify
6313 an inheritance relationship.
6319 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6331 return strEQ(HvNAME(SvSTASH(sv)), name);
6337 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6338 it will be upgraded to one. If C<classname> is non-null then the new SV will
6339 be blessed in the specified package. The new SV is returned and its
6340 reference count is 1.
6346 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6352 SV_CHECK_THINKFIRST(rv);
6355 if (SvTYPE(rv) >= SVt_PVMG) {
6356 U32 refcnt = SvREFCNT(rv);
6360 SvREFCNT(rv) = refcnt;
6363 if (SvTYPE(rv) < SVt_RV)
6364 sv_upgrade(rv, SVt_RV);
6365 else if (SvTYPE(rv) > SVt_RV) {
6366 (void)SvOOK_off(rv);
6367 if (SvPVX(rv) && SvLEN(rv))
6368 Safefree(SvPVX(rv));
6378 HV* stash = gv_stashpv(classname, TRUE);
6379 (void)sv_bless(rv, stash);
6385 =for apidoc sv_setref_pv
6387 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6388 argument will be upgraded to an RV. That RV will be modified to point to
6389 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6390 into the SV. The C<classname> argument indicates the package for the
6391 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6392 will be returned and will have a reference count of 1.
6394 Do not use with other Perl types such as HV, AV, SV, CV, because those
6395 objects will become corrupted by the pointer copy process.
6397 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6403 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6406 sv_setsv(rv, &PL_sv_undef);
6410 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6415 =for apidoc sv_setref_iv
6417 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6418 argument will be upgraded to an RV. That RV will be modified to point to
6419 the new SV. The C<classname> argument indicates the package for the
6420 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6421 will be returned and will have a reference count of 1.
6427 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6429 sv_setiv(newSVrv(rv,classname), iv);
6434 =for apidoc sv_setref_uv
6436 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6437 argument will be upgraded to an RV. That RV will be modified to point to
6438 the new SV. The C<classname> argument indicates the package for the
6439 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6440 will be returned and will have a reference count of 1.
6446 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6448 sv_setuv(newSVrv(rv,classname), uv);
6453 =for apidoc sv_setref_nv
6455 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6456 argument will be upgraded to an RV. That RV will be modified to point to
6457 the new SV. The C<classname> argument indicates the package for the
6458 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6459 will be returned and will have a reference count of 1.
6465 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6467 sv_setnv(newSVrv(rv,classname), nv);
6472 =for apidoc sv_setref_pvn
6474 Copies a string into a new SV, optionally blessing the SV. The length of the
6475 string must be specified with C<n>. The C<rv> argument will be upgraded to
6476 an RV. That RV will be modified to point to the new SV. The C<classname>
6477 argument indicates the package for the blessing. Set C<classname> to
6478 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6479 a reference count of 1.
6481 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6487 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6489 sv_setpvn(newSVrv(rv,classname), pv, n);
6494 =for apidoc sv_bless
6496 Blesses an SV into a specified package. The SV must be an RV. The package
6497 must be designated by its stash (see C<gv_stashpv()>). The reference count
6498 of the SV is unaffected.
6504 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6508 Perl_croak(aTHX_ "Can't bless non-reference value");
6510 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6511 if (SvREADONLY(tmpRef))
6512 Perl_croak(aTHX_ PL_no_modify);
6513 if (SvOBJECT(tmpRef)) {
6514 if (SvTYPE(tmpRef) != SVt_PVIO)
6516 SvREFCNT_dec(SvSTASH(tmpRef));
6519 SvOBJECT_on(tmpRef);
6520 if (SvTYPE(tmpRef) != SVt_PVIO)
6522 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6523 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6534 S_sv_unglob(pTHX_ SV *sv)
6538 assert(SvTYPE(sv) == SVt_PVGV);
6543 SvREFCNT_dec(GvSTASH(sv));
6544 GvSTASH(sv) = Nullhv;
6546 sv_unmagic(sv, '*');
6547 Safefree(GvNAME(sv));
6550 /* need to keep SvANY(sv) in the right arena */
6551 xpvmg = new_XPVMG();
6552 StructCopy(SvANY(sv), xpvmg, XPVMG);
6553 del_XPVGV(SvANY(sv));
6556 SvFLAGS(sv) &= ~SVTYPEMASK;
6557 SvFLAGS(sv) |= SVt_PVMG;
6561 =for apidoc sv_unref_flags
6563 Unsets the RV status of the SV, and decrements the reference count of
6564 whatever was being referenced by the RV. This can almost be thought of
6565 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6566 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6567 (otherwise the decrementing is conditional on the reference count being
6568 different from one or the reference being a readonly SV).
6575 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6579 if (SvWEAKREF(sv)) {
6587 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6589 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6590 sv_2mortal(rv); /* Schedule for freeing later */
6594 =for apidoc sv_unref
6596 Unsets the RV status of the SV, and decrements the reference count of
6597 whatever was being referenced by the RV. This can almost be thought of
6598 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6599 being zero. See C<SvROK_off>.
6605 Perl_sv_unref(pTHX_ SV *sv)
6607 sv_unref_flags(sv, 0);
6611 Perl_sv_taint(pTHX_ SV *sv)
6613 sv_magic((sv), Nullsv, 't', Nullch, 0);
6617 Perl_sv_untaint(pTHX_ SV *sv)
6619 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6620 MAGIC *mg = mg_find(sv, 't');
6627 Perl_sv_tainted(pTHX_ SV *sv)
6629 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6630 MAGIC *mg = mg_find(sv, 't');
6631 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6638 =for apidoc sv_setpviv
6640 Copies an integer into the given SV, also updating its string value.
6641 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6647 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6649 char buf[TYPE_CHARS(UV)];
6651 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6653 sv_setpvn(sv, ptr, ebuf - ptr);
6658 =for apidoc sv_setpviv_mg
6660 Like C<sv_setpviv>, but also handles 'set' magic.
6666 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6668 char buf[TYPE_CHARS(UV)];
6670 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6672 sv_setpvn(sv, ptr, ebuf - ptr);
6676 #if defined(PERL_IMPLICIT_CONTEXT)
6678 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6682 va_start(args, pat);
6683 sv_vsetpvf(sv, pat, &args);
6689 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6693 va_start(args, pat);
6694 sv_vsetpvf_mg(sv, pat, &args);
6700 =for apidoc sv_setpvf
6702 Processes its arguments like C<sprintf> and sets an SV to the formatted
6703 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6709 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6712 va_start(args, pat);
6713 sv_vsetpvf(sv, pat, &args);
6718 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6720 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6724 =for apidoc sv_setpvf_mg
6726 Like C<sv_setpvf>, but also handles 'set' magic.
6732 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6735 va_start(args, pat);
6736 sv_vsetpvf_mg(sv, pat, &args);
6741 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6743 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6747 #if defined(PERL_IMPLICIT_CONTEXT)
6749 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6753 va_start(args, pat);
6754 sv_vcatpvf(sv, pat, &args);
6759 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6763 va_start(args, pat);
6764 sv_vcatpvf_mg(sv, pat, &args);
6770 =for apidoc sv_catpvf
6772 Processes its arguments like C<sprintf> and appends the formatted
6773 output to an SV. If the appended data contains "wide" characters
6774 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6775 and characters >255 formatted with %c), the original SV might get
6776 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6777 C<SvSETMAGIC()> must typically be called after calling this function
6778 to handle 'set' magic.
6783 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6786 va_start(args, pat);
6787 sv_vcatpvf(sv, pat, &args);
6792 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6794 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6798 =for apidoc sv_catpvf_mg
6800 Like C<sv_catpvf>, but also handles 'set' magic.
6806 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6809 va_start(args, pat);
6810 sv_vcatpvf_mg(sv, pat, &args);
6815 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6817 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6822 =for apidoc sv_vsetpvfn
6824 Works like C<vcatpvfn> but copies the text into the SV instead of
6831 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6833 sv_setpvn(sv, "", 0);
6834 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6838 S_expect_number(pTHX_ char** pattern)
6841 switch (**pattern) {
6842 case '1': case '2': case '3':
6843 case '4': case '5': case '6':
6844 case '7': case '8': case '9':
6845 while (isDIGIT(**pattern))
6846 var = var * 10 + (*(*pattern)++ - '0');
6850 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6853 =for apidoc sv_vcatpvfn
6855 Processes its arguments like C<vsprintf> and appends the formatted output
6856 to an SV. Uses an array of SVs if the C style variable argument list is
6857 missing (NULL). When running with taint checks enabled, indicates via
6858 C<maybe_tainted> if results are untrustworthy (often due to the use of
6865 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6872 static char nullstr[] = "(null)";
6875 /* no matter what, this is a string now */
6876 (void)SvPV_force(sv, origlen);
6878 /* special-case "", "%s", and "%_" */
6881 if (patlen == 2 && pat[0] == '%') {
6885 char *s = va_arg(*args, char*);
6886 sv_catpv(sv, s ? s : nullstr);
6888 else if (svix < svmax) {
6889 sv_catsv(sv, *svargs);
6890 if (DO_UTF8(*svargs))
6896 argsv = va_arg(*args, SV*);
6897 sv_catsv(sv, argsv);
6902 /* See comment on '_' below */
6907 patend = (char*)pat + patlen;
6908 for (p = (char*)pat; p < patend; p = q) {
6911 bool vectorize = FALSE;
6912 bool vectorarg = FALSE;
6913 bool vec_utf = FALSE;
6919 bool has_precis = FALSE;
6921 bool is_utf = FALSE;
6924 U8 utf8buf[UTF8_MAXLEN+1];
6925 STRLEN esignlen = 0;
6927 char *eptr = Nullch;
6929 /* Times 4: a decimal digit takes more than 3 binary digits.
6930 * NV_DIG: mantissa takes than many decimal digits.
6931 * Plus 32: Playing safe. */
6932 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6933 /* large enough for "%#.#f" --chip */
6934 /* what about long double NVs? --jhi */
6937 U8 *vecstr = Null(U8*);
6949 STRLEN dotstrlen = 1;
6950 I32 efix = 0; /* explicit format parameter index */
6951 I32 ewix = 0; /* explicit width index */
6952 I32 epix = 0; /* explicit precision index */
6953 I32 evix = 0; /* explicit vector index */
6954 bool asterisk = FALSE;
6956 /* echo everything up to the next format specification */
6957 for (q = p; q < patend && *q != '%'; ++q) ;
6959 sv_catpvn(sv, p, q - p);
6966 We allow format specification elements in this order:
6967 \d+\$ explicit format parameter index
6969 \*?(\d+\$)?v vector with optional (optionally specified) arg
6970 \d+|\*(\d+\$)? width using optional (optionally specified) arg
6971 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
6973 [%bcdefginopsux_DFOUX] format (mandatory)
6975 if (EXPECT_NUMBER(q, width)) {
7016 if (EXPECT_NUMBER(q, ewix))
7025 if ((vectorarg = asterisk)) {
7035 EXPECT_NUMBER(q, width);
7040 vecsv = va_arg(*args, SV*);
7042 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7043 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7044 dotstr = SvPVx(vecsv, dotstrlen);
7049 vecsv = va_arg(*args, SV*);
7050 vecstr = (U8*)SvPVx(vecsv,veclen);
7051 vec_utf = DO_UTF8(vecsv);
7053 else if (efix ? efix <= svmax : svix < svmax) {
7054 vecsv = svargs[efix ? efix-1 : svix++];
7055 vecstr = (U8*)SvPVx(vecsv,veclen);
7056 vec_utf = DO_UTF8(vecsv);
7066 i = va_arg(*args, int);
7068 i = (ewix ? ewix <= svmax : svix < svmax) ?
7069 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7071 width = (i < 0) ? -i : i;
7081 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7084 i = va_arg(*args, int);
7086 i = (ewix ? ewix <= svmax : svix < svmax)
7087 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7088 precis = (i < 0) ? 0 : i;
7093 precis = precis * 10 + (*q++ - '0');
7101 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7112 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7113 if (*(q + 1) == 'l') { /* lld, llf */
7136 argsv = (efix ? efix <= svmax : svix < svmax) ?
7137 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7144 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7146 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7148 eptr = (char*)utf8buf;
7149 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7161 eptr = va_arg(*args, char*);
7163 #ifdef MACOS_TRADITIONAL
7164 /* On MacOS, %#s format is used for Pascal strings */
7169 elen = strlen(eptr);
7172 elen = sizeof nullstr - 1;
7176 eptr = SvPVx(argsv, elen);
7177 if (DO_UTF8(argsv)) {
7178 if (has_precis && precis < elen) {
7180 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7183 if (width) { /* fudge width (can't fudge elen) */
7184 width += elen - sv_len_utf8(argsv);
7193 * The "%_" hack might have to be changed someday,
7194 * if ISO or ANSI decide to use '_' for something.
7195 * So we keep it hidden from users' code.
7199 argsv = va_arg(*args, SV*);
7200 eptr = SvPVx(argsv, elen);
7206 if (has_precis && elen > precis)
7215 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7233 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7243 case 'h': iv = (short)va_arg(*args, int); break;
7244 default: iv = va_arg(*args, int); break;
7245 case 'l': iv = va_arg(*args, long); break;
7246 case 'V': iv = va_arg(*args, IV); break;
7248 case 'q': iv = va_arg(*args, Quad_t); break;
7255 case 'h': iv = (short)iv; break;
7257 case 'l': iv = (long)iv; break;
7260 case 'q': iv = (Quad_t)iv; break;
7267 esignbuf[esignlen++] = plus;
7271 esignbuf[esignlen++] = '-';
7313 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7323 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7324 default: uv = va_arg(*args, unsigned); break;
7325 case 'l': uv = va_arg(*args, unsigned long); break;
7326 case 'V': uv = va_arg(*args, UV); break;
7328 case 'q': uv = va_arg(*args, Quad_t); break;
7335 case 'h': uv = (unsigned short)uv; break;
7337 case 'l': uv = (unsigned long)uv; break;
7340 case 'q': uv = (Quad_t)uv; break;
7346 eptr = ebuf + sizeof ebuf;
7352 p = (char*)((c == 'X')
7353 ? "0123456789ABCDEF" : "0123456789abcdef");
7359 esignbuf[esignlen++] = '0';
7360 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7366 *--eptr = '0' + dig;
7368 if (alt && *eptr != '0')
7374 *--eptr = '0' + dig;
7377 esignbuf[esignlen++] = '0';
7378 esignbuf[esignlen++] = 'b';
7381 default: /* it had better be ten or less */
7382 #if defined(PERL_Y2KWARN)
7383 if (ckWARN(WARN_Y2K)) {
7385 char *s = SvPV(sv,n);
7386 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7387 && (n == 2 || !isDIGIT(s[n-3])))
7389 Perl_warner(aTHX_ WARN_Y2K,
7390 "Possible Y2K bug: %%%c %s",
7391 c, "format string following '19'");
7397 *--eptr = '0' + dig;
7398 } while (uv /= base);
7401 elen = (ebuf + sizeof ebuf) - eptr;
7404 zeros = precis - elen;
7405 else if (precis == 0 && elen == 1 && *eptr == '0')
7410 /* FLOATING POINT */
7413 c = 'f'; /* maybe %F isn't supported here */
7419 /* This is evil, but floating point is even more evil */
7422 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7425 if (c != 'e' && c != 'E') {
7427 (void)Perl_frexp(nv, &i);
7428 if (i == PERL_INT_MIN)
7429 Perl_die(aTHX_ "panic: frexp");
7431 need = BIT_DIGITS(i);
7433 need += has_precis ? precis : 6; /* known default */
7437 need += 20; /* fudge factor */
7438 if (PL_efloatsize < need) {
7439 Safefree(PL_efloatbuf);
7440 PL_efloatsize = need + 20; /* more fudge */
7441 New(906, PL_efloatbuf, PL_efloatsize, char);
7442 PL_efloatbuf[0] = '\0';
7445 eptr = ebuf + sizeof ebuf;
7448 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7450 /* Copy the one or more characters in a long double
7451 * format before the 'base' ([efgEFG]) character to
7452 * the format string. */
7453 static char const prifldbl[] = PERL_PRIfldbl;
7454 char const *p = prifldbl + sizeof(prifldbl) - 3;
7455 while (p >= prifldbl) { *--eptr = *p--; }
7460 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7465 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7477 /* No taint. Otherwise we are in the strange situation
7478 * where printf() taints but print($float) doesn't.
7480 (void)sprintf(PL_efloatbuf, eptr, nv);
7482 eptr = PL_efloatbuf;
7483 elen = strlen(PL_efloatbuf);
7490 i = SvCUR(sv) - origlen;
7493 case 'h': *(va_arg(*args, short*)) = i; break;
7494 default: *(va_arg(*args, int*)) = i; break;
7495 case 'l': *(va_arg(*args, long*)) = i; break;
7496 case 'V': *(va_arg(*args, IV*)) = i; break;
7498 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7503 sv_setuv_mg(argsv, (UV)i);
7504 continue; /* not "break" */
7511 if (!args && ckWARN(WARN_PRINTF) &&
7512 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7513 SV *msg = sv_newmortal();
7514 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7515 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7518 Perl_sv_catpvf(aTHX_ msg,
7519 "\"%%%c\"", c & 0xFF);
7521 Perl_sv_catpvf(aTHX_ msg,
7522 "\"%%\\%03"UVof"\"",
7525 sv_catpv(msg, "end of string");
7526 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7529 /* output mangled stuff ... */
7535 /* ... right here, because formatting flags should not apply */
7536 SvGROW(sv, SvCUR(sv) + elen + 1);
7538 Copy(eptr, p, elen, char);
7541 SvCUR(sv) = p - SvPVX(sv);
7542 continue; /* not "break" */
7545 have = esignlen + zeros + elen;
7546 need = (have > width ? have : width);
7549 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7551 if (esignlen && fill == '0') {
7552 for (i = 0; i < esignlen; i++)
7556 memset(p, fill, gap);
7559 if (esignlen && fill != '0') {
7560 for (i = 0; i < esignlen; i++)
7564 for (i = zeros; i; i--)
7568 Copy(eptr, p, elen, char);
7572 memset(p, ' ', gap);
7577 Copy(dotstr, p, dotstrlen, char);
7581 vectorize = FALSE; /* done iterating over vecstr */
7586 SvCUR(sv) = p - SvPVX(sv);
7594 #if defined(USE_ITHREADS)
7596 #if defined(USE_THREADS)
7597 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7600 #ifndef GpREFCNT_inc
7601 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7605 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7606 #define av_dup(s) (AV*)sv_dup((SV*)s)
7607 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7608 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7609 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7610 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7611 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7612 #define io_dup(s) (IO*)sv_dup((SV*)s)
7613 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7614 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7615 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7616 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7617 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7620 Perl_re_dup(pTHX_ REGEXP *r)
7622 /* XXX fix when pmop->op_pmregexp becomes shared */
7623 return ReREFCNT_inc(r);
7627 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7631 return (PerlIO*)NULL;
7633 /* look for it in the table first */
7634 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7638 /* create anew and remember what it is */
7639 ret = PerlIO_fdupopen(aTHX_ fp);
7640 ptr_table_store(PL_ptr_table, fp, ret);
7645 Perl_dirp_dup(pTHX_ DIR *dp)
7654 Perl_gp_dup(pTHX_ GP *gp)
7659 /* look for it in the table first */
7660 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7664 /* create anew and remember what it is */
7665 Newz(0, ret, 1, GP);
7666 ptr_table_store(PL_ptr_table, gp, ret);
7669 ret->gp_refcnt = 0; /* must be before any other dups! */
7670 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7671 ret->gp_io = io_dup_inc(gp->gp_io);
7672 ret->gp_form = cv_dup_inc(gp->gp_form);
7673 ret->gp_av = av_dup_inc(gp->gp_av);
7674 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7675 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7676 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7677 ret->gp_cvgen = gp->gp_cvgen;
7678 ret->gp_flags = gp->gp_flags;
7679 ret->gp_line = gp->gp_line;
7680 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7685 Perl_mg_dup(pTHX_ MAGIC *mg)
7687 MAGIC *mgprev = (MAGIC*)NULL;
7690 return (MAGIC*)NULL;
7691 /* look for it in the table first */
7692 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7696 for (; mg; mg = mg->mg_moremagic) {
7698 Newz(0, nmg, 1, MAGIC);
7700 mgprev->mg_moremagic = nmg;
7703 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7704 nmg->mg_private = mg->mg_private;
7705 nmg->mg_type = mg->mg_type;
7706 nmg->mg_flags = mg->mg_flags;
7707 if (mg->mg_type == 'r') {
7708 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7711 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7712 ? sv_dup_inc(mg->mg_obj)
7713 : sv_dup(mg->mg_obj);
7715 nmg->mg_len = mg->mg_len;
7716 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7717 if (mg->mg_ptr && mg->mg_type != 'g') {
7718 if (mg->mg_len >= 0) {
7719 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7720 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7721 AMT *amtp = (AMT*)mg->mg_ptr;
7722 AMT *namtp = (AMT*)nmg->mg_ptr;
7724 for (i = 1; i < NofAMmeth; i++) {
7725 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7729 else if (mg->mg_len == HEf_SVKEY)
7730 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7738 Perl_ptr_table_new(pTHX)
7741 Newz(0, tbl, 1, PTR_TBL_t);
7744 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7749 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7751 PTR_TBL_ENT_t *tblent;
7752 UV hash = PTR2UV(sv);
7754 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7755 for (; tblent; tblent = tblent->next) {
7756 if (tblent->oldval == sv)
7757 return tblent->newval;
7763 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7765 PTR_TBL_ENT_t *tblent, **otblent;
7766 /* XXX this may be pessimal on platforms where pointers aren't good
7767 * hash values e.g. if they grow faster in the most significant
7769 UV hash = PTR2UV(oldv);
7773 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7774 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7775 if (tblent->oldval == oldv) {
7776 tblent->newval = newv;
7781 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7782 tblent->oldval = oldv;
7783 tblent->newval = newv;
7784 tblent->next = *otblent;
7787 if (i && tbl->tbl_items > tbl->tbl_max)
7788 ptr_table_split(tbl);
7792 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7794 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7795 UV oldsize = tbl->tbl_max + 1;
7796 UV newsize = oldsize * 2;
7799 Renew(ary, newsize, PTR_TBL_ENT_t*);
7800 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7801 tbl->tbl_max = --newsize;
7803 for (i=0; i < oldsize; i++, ary++) {
7804 PTR_TBL_ENT_t **curentp, **entp, *ent;
7807 curentp = ary + oldsize;
7808 for (entp = ary, ent = *ary; ent; ent = *entp) {
7809 if ((newsize & PTR2UV(ent->oldval)) != i) {
7811 ent->next = *curentp;
7822 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7824 register PTR_TBL_ENT_t **array;
7825 register PTR_TBL_ENT_t *entry;
7826 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7830 if (!tbl || !tbl->tbl_items) {
7834 array = tbl->tbl_ary;
7841 entry = entry->next;
7845 if (++riter > max) {
7848 entry = array[riter];
7856 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7861 ptr_table_clear(tbl);
7862 Safefree(tbl->tbl_ary);
7871 S_gv_share(pTHX_ SV *sstr)
7874 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7876 if (GvIO(gv) || GvFORM(gv)) {
7877 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
7879 else if (!GvCV(gv)) {
7883 /* CvPADLISTs cannot be shared */
7884 if (!CvXSUB(GvCV(gv))) {
7889 if (!GvSHARED(gv)) {
7891 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
7892 HvNAME(GvSTASH(gv)), GvNAME(gv));
7898 * write attempts will die with
7899 * "Modification of a read-only value attempted"
7905 SvREADONLY_on(GvSV(gv));
7912 SvREADONLY_on(GvAV(gv));
7919 SvREADONLY_on(GvAV(gv));
7922 return sstr; /* he_dup() will SvREFCNT_inc() */
7926 Perl_sv_dup(pTHX_ SV *sstr)
7930 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7932 /* look for it in the table first */
7933 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7937 /* create anew and remember what it is */
7939 ptr_table_store(PL_ptr_table, sstr, dstr);
7942 SvFLAGS(dstr) = SvFLAGS(sstr);
7943 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7944 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7947 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7948 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7949 PL_watch_pvx, SvPVX(sstr));
7952 switch (SvTYPE(sstr)) {
7957 SvANY(dstr) = new_XIV();
7958 SvIVX(dstr) = SvIVX(sstr);
7961 SvANY(dstr) = new_XNV();
7962 SvNVX(dstr) = SvNVX(sstr);
7965 SvANY(dstr) = new_XRV();
7966 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7969 SvANY(dstr) = new_XPV();
7970 SvCUR(dstr) = SvCUR(sstr);
7971 SvLEN(dstr) = SvLEN(sstr);
7973 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7974 else if (SvPVX(sstr) && SvLEN(sstr))
7975 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7977 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7980 SvANY(dstr) = new_XPVIV();
7981 SvCUR(dstr) = SvCUR(sstr);
7982 SvLEN(dstr) = SvLEN(sstr);
7983 SvIVX(dstr) = SvIVX(sstr);
7985 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7986 else if (SvPVX(sstr) && SvLEN(sstr))
7987 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7989 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7992 SvANY(dstr) = new_XPVNV();
7993 SvCUR(dstr) = SvCUR(sstr);
7994 SvLEN(dstr) = SvLEN(sstr);
7995 SvIVX(dstr) = SvIVX(sstr);
7996 SvNVX(dstr) = SvNVX(sstr);
7998 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7999 else if (SvPVX(sstr) && SvLEN(sstr))
8000 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8002 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8005 SvANY(dstr) = new_XPVMG();
8006 SvCUR(dstr) = SvCUR(sstr);
8007 SvLEN(dstr) = SvLEN(sstr);
8008 SvIVX(dstr) = SvIVX(sstr);
8009 SvNVX(dstr) = SvNVX(sstr);
8010 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8011 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8013 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8014 else if (SvPVX(sstr) && SvLEN(sstr))
8015 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8017 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8020 SvANY(dstr) = new_XPVBM();
8021 SvCUR(dstr) = SvCUR(sstr);
8022 SvLEN(dstr) = SvLEN(sstr);
8023 SvIVX(dstr) = SvIVX(sstr);
8024 SvNVX(dstr) = SvNVX(sstr);
8025 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8026 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8028 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8029 else if (SvPVX(sstr) && SvLEN(sstr))
8030 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8032 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8033 BmRARE(dstr) = BmRARE(sstr);
8034 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8035 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8038 SvANY(dstr) = new_XPVLV();
8039 SvCUR(dstr) = SvCUR(sstr);
8040 SvLEN(dstr) = SvLEN(sstr);
8041 SvIVX(dstr) = SvIVX(sstr);
8042 SvNVX(dstr) = SvNVX(sstr);
8043 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8044 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8046 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8047 else if (SvPVX(sstr) && SvLEN(sstr))
8048 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8050 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8051 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8052 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8053 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8054 LvTYPE(dstr) = LvTYPE(sstr);
8057 if (GvSHARED((GV*)sstr)) {
8059 if ((share = gv_share(sstr))) {
8063 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8064 HvNAME(GvSTASH(share)), GvNAME(share));
8069 SvANY(dstr) = new_XPVGV();
8070 SvCUR(dstr) = SvCUR(sstr);
8071 SvLEN(dstr) = SvLEN(sstr);
8072 SvIVX(dstr) = SvIVX(sstr);
8073 SvNVX(dstr) = SvNVX(sstr);
8074 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8075 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8077 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8078 else if (SvPVX(sstr) && SvLEN(sstr))
8079 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8081 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8082 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8083 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8084 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8085 GvFLAGS(dstr) = GvFLAGS(sstr);
8086 GvGP(dstr) = gp_dup(GvGP(sstr));
8087 (void)GpREFCNT_inc(GvGP(dstr));
8090 SvANY(dstr) = new_XPVIO();
8091 SvCUR(dstr) = SvCUR(sstr);
8092 SvLEN(dstr) = SvLEN(sstr);
8093 SvIVX(dstr) = SvIVX(sstr);
8094 SvNVX(dstr) = SvNVX(sstr);
8095 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8096 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8098 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8099 else if (SvPVX(sstr) && SvLEN(sstr))
8100 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8102 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8103 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8104 if (IoOFP(sstr) == IoIFP(sstr))
8105 IoOFP(dstr) = IoIFP(dstr);
8107 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8108 /* PL_rsfp_filters entries have fake IoDIRP() */
8109 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8110 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8112 IoDIRP(dstr) = IoDIRP(sstr);
8113 IoLINES(dstr) = IoLINES(sstr);
8114 IoPAGE(dstr) = IoPAGE(sstr);
8115 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8116 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8117 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8118 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8119 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8120 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8121 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8122 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8123 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8124 IoTYPE(dstr) = IoTYPE(sstr);
8125 IoFLAGS(dstr) = IoFLAGS(sstr);
8128 SvANY(dstr) = new_XPVAV();
8129 SvCUR(dstr) = SvCUR(sstr);
8130 SvLEN(dstr) = SvLEN(sstr);
8131 SvIVX(dstr) = SvIVX(sstr);
8132 SvNVX(dstr) = SvNVX(sstr);
8133 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8134 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8135 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8136 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8137 if (AvARRAY((AV*)sstr)) {
8138 SV **dst_ary, **src_ary;
8139 SSize_t items = AvFILLp((AV*)sstr) + 1;
8141 src_ary = AvARRAY((AV*)sstr);
8142 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8143 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8144 SvPVX(dstr) = (char*)dst_ary;
8145 AvALLOC((AV*)dstr) = dst_ary;
8146 if (AvREAL((AV*)sstr)) {
8148 *dst_ary++ = sv_dup_inc(*src_ary++);
8152 *dst_ary++ = sv_dup(*src_ary++);
8154 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8155 while (items-- > 0) {
8156 *dst_ary++ = &PL_sv_undef;
8160 SvPVX(dstr) = Nullch;
8161 AvALLOC((AV*)dstr) = (SV**)NULL;
8165 SvANY(dstr) = new_XPVHV();
8166 SvCUR(dstr) = SvCUR(sstr);
8167 SvLEN(dstr) = SvLEN(sstr);
8168 SvIVX(dstr) = SvIVX(sstr);
8169 SvNVX(dstr) = SvNVX(sstr);
8170 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8171 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8172 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8173 if (HvARRAY((HV*)sstr)) {
8175 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8176 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8177 Newz(0, dxhv->xhv_array,
8178 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8179 while (i <= sxhv->xhv_max) {
8180 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8181 !!HvSHAREKEYS(sstr));
8184 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8187 SvPVX(dstr) = Nullch;
8188 HvEITER((HV*)dstr) = (HE*)NULL;
8190 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8191 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8194 SvANY(dstr) = new_XPVFM();
8195 FmLINES(dstr) = FmLINES(sstr);
8199 SvANY(dstr) = new_XPVCV();
8201 SvCUR(dstr) = SvCUR(sstr);
8202 SvLEN(dstr) = SvLEN(sstr);
8203 SvIVX(dstr) = SvIVX(sstr);
8204 SvNVX(dstr) = SvNVX(sstr);
8205 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8206 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8207 if (SvPVX(sstr) && SvLEN(sstr))
8208 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8210 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8211 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8212 CvSTART(dstr) = CvSTART(sstr);
8213 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8214 CvXSUB(dstr) = CvXSUB(sstr);
8215 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8216 CvGV(dstr) = gv_dup(CvGV(sstr));
8217 CvDEPTH(dstr) = CvDEPTH(sstr);
8218 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8219 /* XXX padlists are real, but pretend to be not */
8220 AvREAL_on(CvPADLIST(sstr));
8221 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8222 AvREAL_off(CvPADLIST(sstr));
8223 AvREAL_off(CvPADLIST(dstr));
8226 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8227 if (!CvANON(sstr) || CvCLONED(sstr))
8228 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8230 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8231 CvFLAGS(dstr) = CvFLAGS(sstr);
8234 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8238 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8245 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8250 return (PERL_CONTEXT*)NULL;
8252 /* look for it in the table first */
8253 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8257 /* create anew and remember what it is */
8258 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8259 ptr_table_store(PL_ptr_table, cxs, ncxs);
8262 PERL_CONTEXT *cx = &cxs[ix];
8263 PERL_CONTEXT *ncx = &ncxs[ix];
8264 ncx->cx_type = cx->cx_type;
8265 if (CxTYPE(cx) == CXt_SUBST) {
8266 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8269 ncx->blk_oldsp = cx->blk_oldsp;
8270 ncx->blk_oldcop = cx->blk_oldcop;
8271 ncx->blk_oldretsp = cx->blk_oldretsp;
8272 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8273 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8274 ncx->blk_oldpm = cx->blk_oldpm;
8275 ncx->blk_gimme = cx->blk_gimme;
8276 switch (CxTYPE(cx)) {
8278 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8279 ? cv_dup_inc(cx->blk_sub.cv)
8280 : cv_dup(cx->blk_sub.cv));
8281 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8282 ? av_dup_inc(cx->blk_sub.argarray)
8284 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8285 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8286 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8287 ncx->blk_sub.lval = cx->blk_sub.lval;
8290 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8291 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8292 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8293 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8294 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8297 ncx->blk_loop.label = cx->blk_loop.label;
8298 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8299 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8300 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8301 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8302 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8303 ? cx->blk_loop.iterdata
8304 : gv_dup((GV*)cx->blk_loop.iterdata));
8305 ncx->blk_loop.oldcurpad
8306 = (SV**)ptr_table_fetch(PL_ptr_table,
8307 cx->blk_loop.oldcurpad);
8308 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8309 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8310 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8311 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8312 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8315 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8316 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8317 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8318 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8331 Perl_si_dup(pTHX_ PERL_SI *si)
8336 return (PERL_SI*)NULL;
8338 /* look for it in the table first */
8339 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8343 /* create anew and remember what it is */
8344 Newz(56, nsi, 1, PERL_SI);
8345 ptr_table_store(PL_ptr_table, si, nsi);
8347 nsi->si_stack = av_dup_inc(si->si_stack);
8348 nsi->si_cxix = si->si_cxix;
8349 nsi->si_cxmax = si->si_cxmax;
8350 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8351 nsi->si_type = si->si_type;
8352 nsi->si_prev = si_dup(si->si_prev);
8353 nsi->si_next = si_dup(si->si_next);
8354 nsi->si_markoff = si->si_markoff;
8359 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8360 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8361 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8362 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8363 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8364 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8365 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8366 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8367 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8368 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8369 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8370 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8373 #define pv_dup_inc(p) SAVEPV(p)
8374 #define pv_dup(p) SAVEPV(p)
8375 #define svp_dup_inc(p,pp) any_dup(p,pp)
8378 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8385 /* look for it in the table first */
8386 ret = ptr_table_fetch(PL_ptr_table, v);
8390 /* see if it is part of the interpreter structure */
8391 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8392 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8400 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8402 ANY *ss = proto_perl->Tsavestack;
8403 I32 ix = proto_perl->Tsavestack_ix;
8404 I32 max = proto_perl->Tsavestack_max;
8417 void (*dptr) (void*);
8418 void (*dxptr) (pTHXo_ void*);
8421 Newz(54, nss, max, ANY);
8427 case SAVEt_ITEM: /* normal string */
8428 sv = (SV*)POPPTR(ss,ix);
8429 TOPPTR(nss,ix) = sv_dup_inc(sv);
8430 sv = (SV*)POPPTR(ss,ix);
8431 TOPPTR(nss,ix) = sv_dup_inc(sv);
8433 case SAVEt_SV: /* scalar reference */
8434 sv = (SV*)POPPTR(ss,ix);
8435 TOPPTR(nss,ix) = sv_dup_inc(sv);
8436 gv = (GV*)POPPTR(ss,ix);
8437 TOPPTR(nss,ix) = gv_dup_inc(gv);
8439 case SAVEt_GENERIC_PVREF: /* generic char* */
8440 c = (char*)POPPTR(ss,ix);
8441 TOPPTR(nss,ix) = pv_dup(c);
8442 ptr = POPPTR(ss,ix);
8443 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8445 case SAVEt_GENERIC_SVREF: /* generic sv */
8446 case SAVEt_SVREF: /* scalar reference */
8447 sv = (SV*)POPPTR(ss,ix);
8448 TOPPTR(nss,ix) = sv_dup_inc(sv);
8449 ptr = POPPTR(ss,ix);
8450 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8452 case SAVEt_AV: /* array reference */
8453 av = (AV*)POPPTR(ss,ix);
8454 TOPPTR(nss,ix) = av_dup_inc(av);
8455 gv = (GV*)POPPTR(ss,ix);
8456 TOPPTR(nss,ix) = gv_dup(gv);
8458 case SAVEt_HV: /* hash reference */
8459 hv = (HV*)POPPTR(ss,ix);
8460 TOPPTR(nss,ix) = hv_dup_inc(hv);
8461 gv = (GV*)POPPTR(ss,ix);
8462 TOPPTR(nss,ix) = gv_dup(gv);
8464 case SAVEt_INT: /* int reference */
8465 ptr = POPPTR(ss,ix);
8466 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8467 intval = (int)POPINT(ss,ix);
8468 TOPINT(nss,ix) = intval;
8470 case SAVEt_LONG: /* long reference */
8471 ptr = POPPTR(ss,ix);
8472 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8473 longval = (long)POPLONG(ss,ix);
8474 TOPLONG(nss,ix) = longval;
8476 case SAVEt_I32: /* I32 reference */
8477 case SAVEt_I16: /* I16 reference */
8478 case SAVEt_I8: /* I8 reference */
8479 ptr = POPPTR(ss,ix);
8480 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8484 case SAVEt_IV: /* IV reference */
8485 ptr = POPPTR(ss,ix);
8486 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8490 case SAVEt_SPTR: /* SV* reference */
8491 ptr = POPPTR(ss,ix);
8492 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8493 sv = (SV*)POPPTR(ss,ix);
8494 TOPPTR(nss,ix) = sv_dup(sv);
8496 case SAVEt_VPTR: /* random* reference */
8497 ptr = POPPTR(ss,ix);
8498 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8499 ptr = POPPTR(ss,ix);
8500 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8502 case SAVEt_PPTR: /* char* reference */
8503 ptr = POPPTR(ss,ix);
8504 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8505 c = (char*)POPPTR(ss,ix);
8506 TOPPTR(nss,ix) = pv_dup(c);
8508 case SAVEt_HPTR: /* HV* reference */
8509 ptr = POPPTR(ss,ix);
8510 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8511 hv = (HV*)POPPTR(ss,ix);
8512 TOPPTR(nss,ix) = hv_dup(hv);
8514 case SAVEt_APTR: /* AV* reference */
8515 ptr = POPPTR(ss,ix);
8516 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8517 av = (AV*)POPPTR(ss,ix);
8518 TOPPTR(nss,ix) = av_dup(av);
8521 gv = (GV*)POPPTR(ss,ix);
8522 TOPPTR(nss,ix) = gv_dup(gv);
8524 case SAVEt_GP: /* scalar reference */
8525 gp = (GP*)POPPTR(ss,ix);
8526 TOPPTR(nss,ix) = gp = gp_dup(gp);
8527 (void)GpREFCNT_inc(gp);
8528 gv = (GV*)POPPTR(ss,ix);
8529 TOPPTR(nss,ix) = gv_dup_inc(c);
8530 c = (char*)POPPTR(ss,ix);
8531 TOPPTR(nss,ix) = pv_dup(c);
8538 case SAVEt_MORTALIZESV:
8539 sv = (SV*)POPPTR(ss,ix);
8540 TOPPTR(nss,ix) = sv_dup_inc(sv);
8543 ptr = POPPTR(ss,ix);
8544 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8545 /* these are assumed to be refcounted properly */
8546 switch (((OP*)ptr)->op_type) {
8553 TOPPTR(nss,ix) = ptr;
8558 TOPPTR(nss,ix) = Nullop;
8563 TOPPTR(nss,ix) = Nullop;
8566 c = (char*)POPPTR(ss,ix);
8567 TOPPTR(nss,ix) = pv_dup_inc(c);
8570 longval = POPLONG(ss,ix);
8571 TOPLONG(nss,ix) = longval;
8574 hv = (HV*)POPPTR(ss,ix);
8575 TOPPTR(nss,ix) = hv_dup_inc(hv);
8576 c = (char*)POPPTR(ss,ix);
8577 TOPPTR(nss,ix) = pv_dup_inc(c);
8581 case SAVEt_DESTRUCTOR:
8582 ptr = POPPTR(ss,ix);
8583 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8584 dptr = POPDPTR(ss,ix);
8585 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8587 case SAVEt_DESTRUCTOR_X:
8588 ptr = POPPTR(ss,ix);
8589 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8590 dxptr = POPDXPTR(ss,ix);
8591 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8593 case SAVEt_REGCONTEXT:
8599 case SAVEt_STACK_POS: /* Position on Perl stack */
8603 case SAVEt_AELEM: /* array element */
8604 sv = (SV*)POPPTR(ss,ix);
8605 TOPPTR(nss,ix) = sv_dup_inc(sv);
8608 av = (AV*)POPPTR(ss,ix);
8609 TOPPTR(nss,ix) = av_dup_inc(av);
8611 case SAVEt_HELEM: /* hash element */
8612 sv = (SV*)POPPTR(ss,ix);
8613 TOPPTR(nss,ix) = sv_dup_inc(sv);
8614 sv = (SV*)POPPTR(ss,ix);
8615 TOPPTR(nss,ix) = sv_dup_inc(sv);
8616 hv = (HV*)POPPTR(ss,ix);
8617 TOPPTR(nss,ix) = hv_dup_inc(hv);
8620 ptr = POPPTR(ss,ix);
8621 TOPPTR(nss,ix) = ptr;
8628 av = (AV*)POPPTR(ss,ix);
8629 TOPPTR(nss,ix) = av_dup(av);
8632 longval = (long)POPLONG(ss,ix);
8633 TOPLONG(nss,ix) = longval;
8634 ptr = POPPTR(ss,ix);
8635 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8636 sv = (SV*)POPPTR(ss,ix);
8637 TOPPTR(nss,ix) = sv_dup(sv);
8640 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8652 perl_clone(PerlInterpreter *proto_perl, UV flags)
8655 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8658 #ifdef PERL_IMPLICIT_SYS
8659 return perl_clone_using(proto_perl, flags,
8661 proto_perl->IMemShared,
8662 proto_perl->IMemParse,
8672 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8673 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8674 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8675 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8676 struct IPerlDir* ipD, struct IPerlSock* ipS,
8677 struct IPerlProc* ipP)
8679 /* XXX many of the string copies here can be optimized if they're
8680 * constants; they need to be allocated as common memory and just
8681 * their pointers copied. */
8685 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8687 PERL_SET_THX(pPerl);
8688 # else /* !PERL_OBJECT */
8689 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8690 PERL_SET_THX(my_perl);
8693 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8699 # else /* !DEBUGGING */
8700 Zero(my_perl, 1, PerlInterpreter);
8701 # endif /* DEBUGGING */
8705 PL_MemShared = ipMS;
8713 # endif /* PERL_OBJECT */
8714 #else /* !PERL_IMPLICIT_SYS */
8716 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8717 PERL_SET_THX(my_perl);
8720 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8726 # else /* !DEBUGGING */
8727 Zero(my_perl, 1, PerlInterpreter);
8728 # endif /* DEBUGGING */
8729 #endif /* PERL_IMPLICIT_SYS */
8732 PL_xiv_arenaroot = NULL;
8734 PL_xnv_arenaroot = NULL;
8736 PL_xrv_arenaroot = NULL;
8738 PL_xpv_arenaroot = NULL;
8740 PL_xpviv_arenaroot = NULL;
8741 PL_xpviv_root = NULL;
8742 PL_xpvnv_arenaroot = NULL;
8743 PL_xpvnv_root = NULL;
8744 PL_xpvcv_arenaroot = NULL;
8745 PL_xpvcv_root = NULL;
8746 PL_xpvav_arenaroot = NULL;
8747 PL_xpvav_root = NULL;
8748 PL_xpvhv_arenaroot = NULL;
8749 PL_xpvhv_root = NULL;
8750 PL_xpvmg_arenaroot = NULL;
8751 PL_xpvmg_root = NULL;
8752 PL_xpvlv_arenaroot = NULL;
8753 PL_xpvlv_root = NULL;
8754 PL_xpvbm_arenaroot = NULL;
8755 PL_xpvbm_root = NULL;
8756 PL_he_arenaroot = NULL;
8758 PL_nice_chunk = NULL;
8759 PL_nice_chunk_size = 0;
8762 PL_sv_root = Nullsv;
8763 PL_sv_arenaroot = Nullsv;
8765 PL_debug = proto_perl->Idebug;
8767 /* create SV map for pointer relocation */
8768 PL_ptr_table = ptr_table_new();
8770 /* initialize these special pointers as early as possible */
8771 SvANY(&PL_sv_undef) = NULL;
8772 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8773 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8774 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8777 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8779 SvANY(&PL_sv_no) = new_XPVNV();
8781 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8782 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8783 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8784 SvCUR(&PL_sv_no) = 0;
8785 SvLEN(&PL_sv_no) = 1;
8786 SvNVX(&PL_sv_no) = 0;
8787 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8790 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8792 SvANY(&PL_sv_yes) = new_XPVNV();
8794 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8795 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8796 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8797 SvCUR(&PL_sv_yes) = 1;
8798 SvLEN(&PL_sv_yes) = 2;
8799 SvNVX(&PL_sv_yes) = 1;
8800 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8802 /* create shared string table */
8803 PL_strtab = newHV();
8804 HvSHAREKEYS_off(PL_strtab);
8805 hv_ksplit(PL_strtab, 512);
8806 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8808 PL_compiling = proto_perl->Icompiling;
8809 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8810 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8811 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8812 if (!specialWARN(PL_compiling.cop_warnings))
8813 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8814 if (!specialCopIO(PL_compiling.cop_io))
8815 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8816 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8818 /* pseudo environmental stuff */
8819 PL_origargc = proto_perl->Iorigargc;
8821 New(0, PL_origargv, i+1, char*);
8822 PL_origargv[i] = '\0';
8824 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8826 PL_envgv = gv_dup(proto_perl->Ienvgv);
8827 PL_incgv = gv_dup(proto_perl->Iincgv);
8828 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8829 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8830 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8831 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8834 PL_minus_c = proto_perl->Iminus_c;
8835 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8836 PL_localpatches = proto_perl->Ilocalpatches;
8837 PL_splitstr = proto_perl->Isplitstr;
8838 PL_preprocess = proto_perl->Ipreprocess;
8839 PL_minus_n = proto_perl->Iminus_n;
8840 PL_minus_p = proto_perl->Iminus_p;
8841 PL_minus_l = proto_perl->Iminus_l;
8842 PL_minus_a = proto_perl->Iminus_a;
8843 PL_minus_F = proto_perl->Iminus_F;
8844 PL_doswitches = proto_perl->Idoswitches;
8845 PL_dowarn = proto_perl->Idowarn;
8846 PL_doextract = proto_perl->Idoextract;
8847 PL_sawampersand = proto_perl->Isawampersand;
8848 PL_unsafe = proto_perl->Iunsafe;
8849 PL_inplace = SAVEPV(proto_perl->Iinplace);
8850 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8851 PL_perldb = proto_perl->Iperldb;
8852 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8854 /* magical thingies */
8855 /* XXX time(&PL_basetime) when asked for? */
8856 PL_basetime = proto_perl->Ibasetime;
8857 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8859 PL_maxsysfd = proto_perl->Imaxsysfd;
8860 PL_multiline = proto_perl->Imultiline;
8861 PL_statusvalue = proto_perl->Istatusvalue;
8863 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8866 /* shortcuts to various I/O objects */
8867 PL_stdingv = gv_dup(proto_perl->Istdingv);
8868 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8869 PL_defgv = gv_dup(proto_perl->Idefgv);
8870 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8871 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8872 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
8874 /* shortcuts to regexp stuff */
8875 PL_replgv = gv_dup(proto_perl->Ireplgv);
8877 /* shortcuts to misc objects */
8878 PL_errgv = gv_dup(proto_perl->Ierrgv);
8880 /* shortcuts to debugging objects */
8881 PL_DBgv = gv_dup(proto_perl->IDBgv);
8882 PL_DBline = gv_dup(proto_perl->IDBline);
8883 PL_DBsub = gv_dup(proto_perl->IDBsub);
8884 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8885 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8886 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8887 PL_lineary = av_dup(proto_perl->Ilineary);
8888 PL_dbargs = av_dup(proto_perl->Idbargs);
8891 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8892 PL_curstash = hv_dup(proto_perl->Tcurstash);
8893 PL_debstash = hv_dup(proto_perl->Idebstash);
8894 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8895 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8897 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8898 PL_endav = av_dup_inc(proto_perl->Iendav);
8899 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8900 PL_initav = av_dup_inc(proto_perl->Iinitav);
8902 PL_sub_generation = proto_perl->Isub_generation;
8904 /* funky return mechanisms */
8905 PL_forkprocess = proto_perl->Iforkprocess;
8907 /* subprocess state */
8908 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8910 /* internal state */
8911 PL_tainting = proto_perl->Itainting;
8912 PL_maxo = proto_perl->Imaxo;
8913 if (proto_perl->Iop_mask)
8914 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8916 PL_op_mask = Nullch;
8918 /* current interpreter roots */
8919 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8920 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8921 PL_main_start = proto_perl->Imain_start;
8922 PL_eval_root = proto_perl->Ieval_root;
8923 PL_eval_start = proto_perl->Ieval_start;
8925 /* runtime control stuff */
8926 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8927 PL_copline = proto_perl->Icopline;
8929 PL_filemode = proto_perl->Ifilemode;
8930 PL_lastfd = proto_perl->Ilastfd;
8931 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8934 PL_gensym = proto_perl->Igensym;
8935 PL_preambled = proto_perl->Ipreambled;
8936 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8937 PL_laststatval = proto_perl->Ilaststatval;
8938 PL_laststype = proto_perl->Ilaststype;
8939 PL_mess_sv = Nullsv;
8941 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8942 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8944 /* interpreter atexit processing */
8945 PL_exitlistlen = proto_perl->Iexitlistlen;
8946 if (PL_exitlistlen) {
8947 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8948 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8951 PL_exitlist = (PerlExitListEntry*)NULL;
8952 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8954 PL_profiledata = NULL;
8955 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8956 /* PL_rsfp_filters entries have fake IoDIRP() */
8957 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8959 PL_compcv = cv_dup(proto_perl->Icompcv);
8960 PL_comppad = av_dup(proto_perl->Icomppad);
8961 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8962 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8963 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8964 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8965 proto_perl->Tcurpad);
8967 #ifdef HAVE_INTERP_INTERN
8968 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8971 /* more statics moved here */
8972 PL_generation = proto_perl->Igeneration;
8973 PL_DBcv = cv_dup(proto_perl->IDBcv);
8975 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8976 PL_in_clean_all = proto_perl->Iin_clean_all;
8978 PL_uid = proto_perl->Iuid;
8979 PL_euid = proto_perl->Ieuid;
8980 PL_gid = proto_perl->Igid;
8981 PL_egid = proto_perl->Iegid;
8982 PL_nomemok = proto_perl->Inomemok;
8983 PL_an = proto_perl->Ian;
8984 PL_cop_seqmax = proto_perl->Icop_seqmax;
8985 PL_op_seqmax = proto_perl->Iop_seqmax;
8986 PL_evalseq = proto_perl->Ievalseq;
8987 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8988 PL_origalen = proto_perl->Iorigalen;
8989 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8990 PL_osname = SAVEPV(proto_perl->Iosname);
8991 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8992 PL_sighandlerp = proto_perl->Isighandlerp;
8995 PL_runops = proto_perl->Irunops;
8997 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9000 PL_cshlen = proto_perl->Icshlen;
9001 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9004 PL_lex_state = proto_perl->Ilex_state;
9005 PL_lex_defer = proto_perl->Ilex_defer;
9006 PL_lex_expect = proto_perl->Ilex_expect;
9007 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9008 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9009 PL_lex_starts = proto_perl->Ilex_starts;
9010 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
9011 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
9012 PL_lex_op = proto_perl->Ilex_op;
9013 PL_lex_inpat = proto_perl->Ilex_inpat;
9014 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9015 PL_lex_brackets = proto_perl->Ilex_brackets;
9016 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9017 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9018 PL_lex_casemods = proto_perl->Ilex_casemods;
9019 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9020 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9022 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9023 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9024 PL_nexttoke = proto_perl->Inexttoke;
9026 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9027 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9028 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9029 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9030 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9031 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9032 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9033 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9034 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9035 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9036 PL_pending_ident = proto_perl->Ipending_ident;
9037 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9039 PL_expect = proto_perl->Iexpect;
9041 PL_multi_start = proto_perl->Imulti_start;
9042 PL_multi_end = proto_perl->Imulti_end;
9043 PL_multi_open = proto_perl->Imulti_open;
9044 PL_multi_close = proto_perl->Imulti_close;
9046 PL_error_count = proto_perl->Ierror_count;
9047 PL_subline = proto_perl->Isubline;
9048 PL_subname = sv_dup_inc(proto_perl->Isubname);
9050 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9051 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9052 PL_padix = proto_perl->Ipadix;
9053 PL_padix_floor = proto_perl->Ipadix_floor;
9054 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9056 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9057 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9058 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9059 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9060 PL_last_lop_op = proto_perl->Ilast_lop_op;
9061 PL_in_my = proto_perl->Iin_my;
9062 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9064 PL_cryptseen = proto_perl->Icryptseen;
9067 PL_hints = proto_perl->Ihints;
9069 PL_amagic_generation = proto_perl->Iamagic_generation;
9071 #ifdef USE_LOCALE_COLLATE
9072 PL_collation_ix = proto_perl->Icollation_ix;
9073 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9074 PL_collation_standard = proto_perl->Icollation_standard;
9075 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9076 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9077 #endif /* USE_LOCALE_COLLATE */
9079 #ifdef USE_LOCALE_NUMERIC
9080 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9081 PL_numeric_standard = proto_perl->Inumeric_standard;
9082 PL_numeric_local = proto_perl->Inumeric_local;
9083 PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix);
9084 #endif /* !USE_LOCALE_NUMERIC */
9086 /* utf8 character classes */
9087 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9088 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9089 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9090 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9091 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9092 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9093 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9094 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9095 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9096 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9097 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9098 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9099 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9100 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9101 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9102 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9103 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9106 PL_last_swash_hv = Nullhv; /* reinits on demand */
9107 PL_last_swash_klen = 0;
9108 PL_last_swash_key[0]= '\0';
9109 PL_last_swash_tmps = (U8*)NULL;
9110 PL_last_swash_slen = 0;
9112 /* perly.c globals */
9113 PL_yydebug = proto_perl->Iyydebug;
9114 PL_yynerrs = proto_perl->Iyynerrs;
9115 PL_yyerrflag = proto_perl->Iyyerrflag;
9116 PL_yychar = proto_perl->Iyychar;
9117 PL_yyval = proto_perl->Iyyval;
9118 PL_yylval = proto_perl->Iyylval;
9120 PL_glob_index = proto_perl->Iglob_index;
9121 PL_srand_called = proto_perl->Isrand_called;
9122 PL_uudmap['M'] = 0; /* reinits on demand */
9123 PL_bitcount = Nullch; /* reinits on demand */
9125 if (proto_perl->Ipsig_pend) {
9126 Newz(0, PL_psig_pend, SIG_SIZE, int);
9129 PL_psig_pend = (int*)NULL;
9132 if (proto_perl->Ipsig_ptr) {
9133 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9134 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9135 for (i = 1; i < SIG_SIZE; i++) {
9136 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9137 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9141 PL_psig_ptr = (SV**)NULL;
9142 PL_psig_name = (SV**)NULL;
9145 /* thrdvar.h stuff */
9147 if (flags & CLONEf_COPY_STACKS) {
9148 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9149 PL_tmps_ix = proto_perl->Ttmps_ix;
9150 PL_tmps_max = proto_perl->Ttmps_max;
9151 PL_tmps_floor = proto_perl->Ttmps_floor;
9152 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9154 while (i <= PL_tmps_ix) {
9155 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9159 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9160 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9161 Newz(54, PL_markstack, i, I32);
9162 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9163 - proto_perl->Tmarkstack);
9164 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9165 - proto_perl->Tmarkstack);
9166 Copy(proto_perl->Tmarkstack, PL_markstack,
9167 PL_markstack_ptr - PL_markstack + 1, I32);
9169 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9170 * NOTE: unlike the others! */
9171 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9172 PL_scopestack_max = proto_perl->Tscopestack_max;
9173 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9174 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9176 /* next push_return() sets PL_retstack[PL_retstack_ix]
9177 * NOTE: unlike the others! */
9178 PL_retstack_ix = proto_perl->Tretstack_ix;
9179 PL_retstack_max = proto_perl->Tretstack_max;
9180 Newz(54, PL_retstack, PL_retstack_max, OP*);
9181 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9183 /* NOTE: si_dup() looks at PL_markstack */
9184 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9186 /* PL_curstack = PL_curstackinfo->si_stack; */
9187 PL_curstack = av_dup(proto_perl->Tcurstack);
9188 PL_mainstack = av_dup(proto_perl->Tmainstack);
9190 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9191 PL_stack_base = AvARRAY(PL_curstack);
9192 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9193 - proto_perl->Tstack_base);
9194 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9196 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9197 * NOTE: unlike the others! */
9198 PL_savestack_ix = proto_perl->Tsavestack_ix;
9199 PL_savestack_max = proto_perl->Tsavestack_max;
9200 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9201 PL_savestack = ss_dup(proto_perl);
9205 ENTER; /* perl_destruct() wants to LEAVE; */
9208 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9209 PL_top_env = &PL_start_env;
9211 PL_op = proto_perl->Top;
9214 PL_Xpv = (XPV*)NULL;
9215 PL_na = proto_perl->Tna;
9217 PL_statbuf = proto_perl->Tstatbuf;
9218 PL_statcache = proto_perl->Tstatcache;
9219 PL_statgv = gv_dup(proto_perl->Tstatgv);
9220 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9222 PL_timesbuf = proto_perl->Ttimesbuf;
9225 PL_tainted = proto_perl->Ttainted;
9226 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9227 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9228 PL_rs = sv_dup_inc(proto_perl->Trs);
9229 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9230 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9231 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9232 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9233 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9234 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9235 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9237 PL_restartop = proto_perl->Trestartop;
9238 PL_in_eval = proto_perl->Tin_eval;
9239 PL_delaymagic = proto_perl->Tdelaymagic;
9240 PL_dirty = proto_perl->Tdirty;
9241 PL_localizing = proto_perl->Tlocalizing;
9243 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9244 PL_protect = proto_perl->Tprotect;
9246 PL_errors = sv_dup_inc(proto_perl->Terrors);
9247 PL_av_fetch_sv = Nullsv;
9248 PL_hv_fetch_sv = Nullsv;
9249 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9250 PL_modcount = proto_perl->Tmodcount;
9251 PL_lastgotoprobe = Nullop;
9252 PL_dumpindent = proto_perl->Tdumpindent;
9254 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9255 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9256 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9257 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9258 PL_sortcxix = proto_perl->Tsortcxix;
9259 PL_efloatbuf = Nullch; /* reinits on demand */
9260 PL_efloatsize = 0; /* reinits on demand */
9264 PL_screamfirst = NULL;
9265 PL_screamnext = NULL;
9266 PL_maxscream = -1; /* reinits on demand */
9267 PL_lastscream = Nullsv;
9269 PL_watchaddr = NULL;
9270 PL_watchok = Nullch;
9272 PL_regdummy = proto_perl->Tregdummy;
9273 PL_regcomp_parse = Nullch;
9274 PL_regxend = Nullch;
9275 PL_regcode = (regnode*)NULL;
9278 PL_regprecomp = Nullch;
9283 PL_seen_zerolen = 0;
9285 PL_regcomp_rx = (regexp*)NULL;
9287 PL_colorset = 0; /* reinits PL_colors[] */
9288 /*PL_colors[6] = {0,0,0,0,0,0};*/
9289 PL_reg_whilem_seen = 0;
9290 PL_reginput = Nullch;
9293 PL_regstartp = (I32*)NULL;
9294 PL_regendp = (I32*)NULL;
9295 PL_reglastparen = (U32*)NULL;
9296 PL_regtill = Nullch;
9298 PL_reg_start_tmp = (char**)NULL;
9299 PL_reg_start_tmpl = 0;
9300 PL_regdata = (struct reg_data*)NULL;
9303 PL_reg_eval_set = 0;
9305 PL_regprogram = (regnode*)NULL;
9307 PL_regcc = (CURCUR*)NULL;
9308 PL_reg_call_cc = (struct re_cc_state*)NULL;
9309 PL_reg_re = (regexp*)NULL;
9310 PL_reg_ganch = Nullch;
9312 PL_reg_magic = (MAGIC*)NULL;
9314 PL_reg_oldcurpm = (PMOP*)NULL;
9315 PL_reg_curpm = (PMOP*)NULL;
9316 PL_reg_oldsaved = Nullch;
9317 PL_reg_oldsavedlen = 0;
9319 PL_reg_leftiter = 0;
9320 PL_reg_poscache = Nullch;
9321 PL_reg_poscache_size= 0;
9323 /* RE engine - function pointers */
9324 PL_regcompp = proto_perl->Tregcompp;
9325 PL_regexecp = proto_perl->Tregexecp;
9326 PL_regint_start = proto_perl->Tregint_start;
9327 PL_regint_string = proto_perl->Tregint_string;
9328 PL_regfree = proto_perl->Tregfree;
9330 PL_reginterp_cnt = 0;
9331 PL_reg_starttry = 0;
9333 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9334 ptr_table_free(PL_ptr_table);
9335 PL_ptr_table = NULL;
9339 return (PerlInterpreter*)pPerl;
9345 #else /* !USE_ITHREADS */
9351 #endif /* USE_ITHREADS */
9354 do_report_used(pTHXo_ SV *sv)
9356 if (SvTYPE(sv) != SVTYPEMASK) {
9357 PerlIO_printf(Perl_debug_log, "****\n");
9363 do_clean_objs(pTHXo_ SV *sv)
9367 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9368 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9369 if (SvWEAKREF(sv)) {
9380 /* XXX Might want to check arrays, etc. */
9383 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9385 do_clean_named_objs(pTHXo_ SV *sv)
9387 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9388 if ( SvOBJECT(GvSV(sv)) ||
9389 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9390 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9391 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9392 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9394 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9402 do_clean_all(pTHXo_ SV *sv)
9404 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9405 SvFLAGS(sv) |= SVf_BREAK;