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)
1434 char *limit = tmpbuf + sizeof(tmpbuf) - 8;
1435 /* each *s can expand to 4 chars + "...\0",
1436 i.e. need room for 8 chars */
1438 for (s = SvPVX(sv); *s && 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 (isPRINT_LC(ch))
1476 Perl_warner(aTHX_ WARN_NUMERIC,
1477 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1478 PL_op_desc[PL_op->op_type]);
1480 Perl_warner(aTHX_ WARN_NUMERIC,
1481 "Argument \"%s\" isn't numeric", tmpbuf);
1484 /* the number can be converted to integer with atol() or atoll() although */
1485 #define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
1486 #define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
1487 #define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
1488 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1489 #define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
1490 #define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
1491 #define IS_NUMBER_NEG 0x40 /* seen a leading - */
1492 #define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
1494 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1495 until proven guilty, assume that things are not that bad... */
1497 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1498 an IV (an assumption perl has been based on to date) it becomes necessary
1499 to remove the assumption that the NV always carries enough precision to
1500 recreate the IV whenever needed, and that the NV is the canonical form.
1501 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1502 precision as an side effect of conversion (which would lead to insanity
1503 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1504 1) to distinguish between IV/UV/NV slots that have cached a valid
1505 conversion where precision was lost and IV/UV/NV slots that have a
1506 valid conversion which has lost no precision
1507 2) to ensure that if a numeric conversion to one form is request that
1508 would lose precision, the precise conversion (or differently
1509 imprecise conversion) is also performed and cached, to prevent
1510 requests for different numeric formats on the same SV causing
1511 lossy conversion chains. (lossless conversion chains are perfectly
1516 SvIOKp is true if the IV slot contains a valid value
1517 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1518 SvNOKp is true if the NV slot contains a valid value
1519 SvNOK is true only if the NV value is accurate
1522 while converting from PV to NV check to see if converting that NV to an
1523 IV(or UV) would lose accuracy over a direct conversion from PV to
1524 IV(or UV). If it would, cache both conversions, return NV, but mark
1525 SV as IOK NOKp (ie not NOK).
1527 while converting from PV to IV check to see if converting that IV to an
1528 NV would lose accuracy over a direct conversion from PV to NV. If it
1529 would, cache both conversions, flag similarly.
1531 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1532 correctly because if IV & NV were set NV *always* overruled.
1533 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1534 changes - now IV and NV together means that the two are interchangeable
1535 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1537 The benefit of this is operations such as pp_add know that if SvIOK is
1538 true for both left and right operands, then integer addition can be
1539 used instead of floating point. (for cases where the result won't
1540 overflow) Before, floating point was always used, which could lead to
1541 loss of precision compared with integer addition.
1543 * making IV and NV equal status should make maths accurate on 64 bit
1545 * may speed up maths somewhat if pp_add and friends start to use
1546 integers when possible instead of fp. (hopefully the overhead in
1547 looking for SvIOK and checking for overflow will not outweigh the
1548 fp to integer speedup)
1549 * will slow down integer operations (callers of SvIV) on "inaccurate"
1550 values, as the change from SvIOK to SvIOKp will cause a call into
1551 sv_2iv each time rather than a macro access direct to the IV slot
1552 * should speed up number->string conversion on integers as IV is
1553 favoured when IV and NV equally accurate
1555 ####################################################################
1556 You had better be using SvIOK_notUV if you want an IV for arithmetic
1557 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1558 SvUOK is true iff UV.
1559 ####################################################################
1561 Your mileage will vary depending your CPUs relative fp to integer
1565 #ifndef NV_PRESERVES_UV
1566 #define IS_NUMBER_UNDERFLOW_IV 1
1567 #define IS_NUMBER_UNDERFLOW_UV 2
1568 #define IS_NUMBER_IV_AND_UV 2
1569 #define IS_NUMBER_OVERFLOW_IV 4
1570 #define IS_NUMBER_OVERFLOW_UV 5
1571 /* Hopefully your optimiser will consider inlining these two functions. */
1573 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1574 NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
1575 UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
1576 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));
1577 if (nv_as_uv <= (UV)IV_MAX) {
1578 (void)SvIOKp_on(sv);
1579 (void)SvNOKp_on(sv);
1580 /* Within suitable range to fit in an IV, atol won't overflow */
1581 /* XXX quite sure? Is that your final answer? not really, I'm
1582 trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1583 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1584 if (numtype & IS_NUMBER_NOT_INT) {
1585 /* I believe that even if the original PV had decimals, they
1586 are lost beyond the limit of the FP precision.
1587 However, neither is canonical, so both only get p flags.
1589 /* Both already have p flags, so do nothing */
1590 } else if (SvIVX(sv) == I_V(nv)) {
1595 /* It had no "." so it must be integer. assert (get in here from
1596 sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1597 IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1598 conversion routines need audit. */
1600 return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1602 /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1603 (void)SvIOKp_on(sv);
1604 (void)SvNOKp_on(sv);
1607 int save_errno = errno;
1609 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1611 if (numtype & IS_NUMBER_NOT_INT) {
1612 /* UV and NV both imprecise. */
1614 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1623 return IS_NUMBER_OVERFLOW_IV;
1627 /* Must have just overflowed UV, but not enough that an NV could spot
1629 return IS_NUMBER_OVERFLOW_UV;
1632 /* We've just lost integer precision, nothing we could do. */
1633 SvUVX(sv) = nv_as_uv;
1634 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));
1635 /* UV and NV slots equally valid only if we have casting symmetry. */
1636 if (numtype & IS_NUMBER_NOT_INT) {
1638 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1639 /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1640 UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1641 get to this point if NVs don't preserve UVs) */
1646 /* As above, I believe UV at least as good as NV */
1649 #endif /* HAS_STRTOUL */
1650 return IS_NUMBER_OVERFLOW_IV;
1653 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1655 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1657 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));
1658 if (SvNVX(sv) < (NV)IV_MIN) {
1659 (void)SvIOKp_on(sv);
1662 return IS_NUMBER_UNDERFLOW_IV;
1664 if (SvNVX(sv) > (NV)UV_MAX) {
1665 (void)SvIOKp_on(sv);
1669 return IS_NUMBER_OVERFLOW_UV;
1671 if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1672 (void)SvIOKp_on(sv);
1674 /* Can't use strtol etc to convert this string */
1675 if (SvNVX(sv) <= (UV)IV_MAX) {
1676 SvIVX(sv) = I_V(SvNVX(sv));
1677 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1678 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1680 /* Integer is imprecise. NOK, IOKp */
1682 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1685 SvUVX(sv) = U_V(SvNVX(sv));
1686 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1687 if (SvUVX(sv) == UV_MAX) {
1688 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1689 possibly be preserved by NV. Hence, it must be overflow.
1691 return IS_NUMBER_OVERFLOW_UV;
1693 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1695 /* Integer is imprecise. NOK, IOKp */
1697 return IS_NUMBER_OVERFLOW_IV;
1699 return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
1701 #endif /* NV_PRESERVES_UV*/
1704 Perl_sv_2iv(pTHX_ register SV *sv)
1708 if (SvGMAGICAL(sv)) {
1713 return I_V(SvNVX(sv));
1715 if (SvPOKp(sv) && SvLEN(sv))
1718 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1719 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1725 if (SvTHINKFIRST(sv)) {
1728 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1729 (SvRV(tmpstr) != SvRV(sv)))
1730 return SvIV(tmpstr);
1731 return PTR2IV(SvRV(sv));
1733 if (SvREADONLY(sv) && SvFAKE(sv)) {
1734 sv_force_normal(sv);
1736 if (SvREADONLY(sv) && !SvOK(sv)) {
1737 if (ckWARN(WARN_UNINITIALIZED))
1744 return (IV)(SvUVX(sv));
1751 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1752 * without also getting a cached IV/UV from it at the same time
1753 * (ie PV->NV conversion should detect loss of accuracy and cache
1754 * IV or UV at same time to avoid this. NWC */
1756 if (SvTYPE(sv) == SVt_NV)
1757 sv_upgrade(sv, SVt_PVNV);
1759 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1760 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1761 certainly cast into the IV range at IV_MAX, whereas the correct
1762 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1764 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1765 SvIVX(sv) = I_V(SvNVX(sv));
1766 if (SvNVX(sv) == (NV) SvIVX(sv)
1767 #ifndef NV_PRESERVES_UV
1768 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1769 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1770 /* Don't flag it as "accurately an integer" if the number
1771 came from a (by definition imprecise) NV operation, and
1772 we're outside the range of NV integer precision */
1775 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1776 DEBUG_c(PerlIO_printf(Perl_debug_log,
1777 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1783 /* IV not precise. No need to convert from PV, as NV
1784 conversion would already have cached IV if it detected
1785 that PV->IV would be better than PV->NV->IV
1786 flags already correct - don't set public IOK. */
1787 DEBUG_c(PerlIO_printf(Perl_debug_log,
1788 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1793 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1794 but the cast (NV)IV_MIN rounds to a the value less (more
1795 negative) than IV_MIN which happens to be equal to SvNVX ??
1796 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1797 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1798 (NV)UVX == NVX are both true, but the values differ. :-(
1799 Hopefully for 2s complement IV_MIN is something like
1800 0x8000000000000000 which will be exact. NWC */
1803 SvUVX(sv) = U_V(SvNVX(sv));
1805 (SvNVX(sv) == (NV) SvUVX(sv))
1806 #ifndef NV_PRESERVES_UV
1807 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1808 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1809 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1810 /* Don't flag it as "accurately an integer" if the number
1811 came from a (by definition imprecise) NV operation, and
1812 we're outside the range of NV integer precision */
1818 DEBUG_c(PerlIO_printf(Perl_debug_log,
1819 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1823 return (IV)SvUVX(sv);
1826 else if (SvPOKp(sv) && SvLEN(sv)) {
1827 I32 numtype = looks_like_number(sv);
1829 /* We want to avoid a possible problem when we cache an IV which
1830 may be later translated to an NV, and the resulting NV is not
1831 the translation of the initial data.
1833 This means that if we cache such an IV, we need to cache the
1834 NV as well. Moreover, we trade speed for space, and do not
1835 cache the NV if we are sure it's not needed.
1838 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1839 /* The NV may be reconstructed from IV - safe to cache IV,
1840 which may be calculated by atol(). */
1841 if (SvTYPE(sv) < SVt_PVIV)
1842 sv_upgrade(sv, SVt_PVIV);
1844 SvIVX(sv) = Atol(SvPVX(sv));
1848 int save_errno = errno;
1849 /* Is it an integer that we could convert with strtol?
1850 So try it, and if it doesn't set errno then it's pukka.
1851 This should be faster than going atof and then thinking. */
1852 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1853 == IS_NUMBER_TO_INT_BY_STRTOL)
1854 /* && is a sequence point. Without it not sure if I'm trying
1855 to do too much between sequence points and hence going
1857 && ((errno = 0), 1) /* , 1 so always true */
1858 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1860 if (SvTYPE(sv) < SVt_PVIV)
1861 sv_upgrade(sv, SVt_PVIV);
1870 /* Hopefully trace flow will optimise this away where possible
1874 /* It wasn't an integer, or it overflowed, or we don't have
1875 strtol. Do things the slow way - check if it's a UV etc. */
1876 d = Atof(SvPVX(sv));
1878 if (SvTYPE(sv) < SVt_PVNV)
1879 sv_upgrade(sv, SVt_PVNV);
1882 if (! numtype && ckWARN(WARN_NUMERIC))
1885 #if defined(USE_LONG_DOUBLE)
1886 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1887 PTR2UV(sv), SvNVX(sv)));
1889 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1890 PTR2UV(sv), SvNVX(sv)));
1894 #ifdef NV_PRESERVES_UV
1895 (void)SvIOKp_on(sv);
1897 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1898 SvIVX(sv) = I_V(SvNVX(sv));
1899 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1902 /* Integer is imprecise. NOK, IOKp */
1904 /* UV will not work better than IV */
1906 if (SvNVX(sv) > (NV)UV_MAX) {
1908 /* Integer is inaccurate. NOK, IOKp, is UV */
1912 SvUVX(sv) = U_V(SvNVX(sv));
1913 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1914 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1918 /* Integer is imprecise. NOK, IOKp, is UV */
1924 #else /* NV_PRESERVES_UV */
1925 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1926 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1927 /* Small enough to preserve all bits. */
1928 (void)SvIOKp_on(sv);
1930 SvIVX(sv) = I_V(SvNVX(sv));
1931 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1933 /* Assumption: first non-preserved integer is < IV_MAX,
1934 this NV is in the preserved range, therefore: */
1935 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1937 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);
1939 } else if (sv_2iuv_non_preserve (sv, numtype)
1940 >= IS_NUMBER_OVERFLOW_IV)
1942 #endif /* NV_PRESERVES_UV */
1946 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1948 if (SvTYPE(sv) < SVt_IV)
1949 /* Typically the caller expects that sv_any is not NULL now. */
1950 sv_upgrade(sv, SVt_IV);
1953 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1954 PTR2UV(sv),SvIVX(sv)));
1955 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1959 Perl_sv_2uv(pTHX_ register SV *sv)
1963 if (SvGMAGICAL(sv)) {
1968 return U_V(SvNVX(sv));
1969 if (SvPOKp(sv) && SvLEN(sv))
1972 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1973 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1979 if (SvTHINKFIRST(sv)) {
1982 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1983 (SvRV(tmpstr) != SvRV(sv)))
1984 return SvUV(tmpstr);
1985 return PTR2UV(SvRV(sv));
1987 if (SvREADONLY(sv) && SvFAKE(sv)) {
1988 sv_force_normal(sv);
1990 if (SvREADONLY(sv) && !SvOK(sv)) {
1991 if (ckWARN(WARN_UNINITIALIZED))
2001 return (UV)SvIVX(sv);
2005 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2006 * without also getting a cached IV/UV from it at the same time
2007 * (ie PV->NV conversion should detect loss of accuracy and cache
2008 * IV or UV at same time to avoid this. */
2009 /* IV-over-UV optimisation - choose to cache IV if possible */
2011 if (SvTYPE(sv) == SVt_NV)
2012 sv_upgrade(sv, SVt_PVNV);
2014 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2015 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2016 SvIVX(sv) = I_V(SvNVX(sv));
2017 if (SvNVX(sv) == (NV) SvIVX(sv)
2018 #ifndef NV_PRESERVES_UV
2019 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2020 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2021 /* Don't flag it as "accurately an integer" if the number
2022 came from a (by definition imprecise) NV operation, and
2023 we're outside the range of NV integer precision */
2026 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2027 DEBUG_c(PerlIO_printf(Perl_debug_log,
2028 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2034 /* IV not precise. No need to convert from PV, as NV
2035 conversion would already have cached IV if it detected
2036 that PV->IV would be better than PV->NV->IV
2037 flags already correct - don't set public IOK. */
2038 DEBUG_c(PerlIO_printf(Perl_debug_log,
2039 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2044 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2045 but the cast (NV)IV_MIN rounds to a the value less (more
2046 negative) than IV_MIN which happens to be equal to SvNVX ??
2047 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2048 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2049 (NV)UVX == NVX are both true, but the values differ. :-(
2050 Hopefully for 2s complement IV_MIN is something like
2051 0x8000000000000000 which will be exact. NWC */
2054 SvUVX(sv) = U_V(SvNVX(sv));
2056 (SvNVX(sv) == (NV) SvUVX(sv))
2057 #ifndef NV_PRESERVES_UV
2058 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2059 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2060 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2061 /* Don't flag it as "accurately an integer" if the number
2062 came from a (by definition imprecise) NV operation, and
2063 we're outside the range of NV integer precision */
2068 DEBUG_c(PerlIO_printf(Perl_debug_log,
2069 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2075 else if (SvPOKp(sv) && SvLEN(sv)) {
2076 I32 numtype = looks_like_number(sv);
2078 /* We want to avoid a possible problem when we cache a UV which
2079 may be later translated to an NV, and the resulting NV is not
2080 the translation of the initial data.
2082 This means that if we cache such a UV, we need to cache the
2083 NV as well. Moreover, we trade speed for space, and do not
2084 cache the NV if not needed.
2087 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2088 /* The NV may be reconstructed from IV - safe to cache IV,
2089 which may be calculated by atol(). */
2090 if (SvTYPE(sv) < SVt_PVIV)
2091 sv_upgrade(sv, SVt_PVIV);
2093 SvIVX(sv) = Atol(SvPVX(sv));
2097 char *num_begin = SvPVX(sv);
2098 int save_errno = errno;
2100 /* seems that strtoul taking numbers that start with - is
2101 implementation dependant, and can't be relied upon. */
2102 if (numtype & IS_NUMBER_NEG) {
2103 /* Not totally defensive. assumine that looks_like_num
2104 didn't lie about a - sign */
2105 while (isSPACE(*num_begin))
2107 if (*num_begin == '-')
2111 /* Is it an integer that we could convert with strtoul?
2112 So try it, and if it doesn't set errno then it's pukka.
2113 This should be faster than going atof and then thinking. */
2114 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2115 == IS_NUMBER_TO_INT_BY_STRTOL)
2116 && ((errno = 0), 1) /* always true */
2117 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2119 /* If known to be negative, check it didn't undeflow IV
2120 XXX possibly we should put more negative values as NVs
2121 direct rather than go via atof below */
2122 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2125 if (SvTYPE(sv) < SVt_PVIV)
2126 sv_upgrade(sv, SVt_PVIV);
2129 /* If it's negative must use IV.
2130 IV-over-UV optimisation */
2131 if (numtype & IS_NUMBER_NEG) {
2133 } else if (u <= (UV) IV_MAX) {
2136 /* it didn't overflow, and it was positive. */
2145 /* Hopefully trace flow will optimise this away where possible
2149 /* It wasn't an integer, or it overflowed, or we don't have
2150 strtol. Do things the slow way - check if it's a IV etc. */
2151 d = Atof(SvPVX(sv));
2153 if (SvTYPE(sv) < SVt_PVNV)
2154 sv_upgrade(sv, SVt_PVNV);
2157 if (! numtype && ckWARN(WARN_NUMERIC))
2160 #if defined(USE_LONG_DOUBLE)
2161 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2162 PTR2UV(sv), SvNVX(sv)));
2164 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2165 PTR2UV(sv), SvNVX(sv)));
2168 #ifdef NV_PRESERVES_UV
2169 (void)SvIOKp_on(sv);
2171 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2172 SvIVX(sv) = I_V(SvNVX(sv));
2173 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2176 /* Integer is imprecise. NOK, IOKp */
2178 /* UV will not work better than IV */
2180 if (SvNVX(sv) > (NV)UV_MAX) {
2182 /* Integer is inaccurate. NOK, IOKp, is UV */
2186 SvUVX(sv) = U_V(SvNVX(sv));
2187 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2188 NV preservse UV so can do correct comparison. */
2189 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2193 /* Integer is imprecise. NOK, IOKp, is UV */
2198 #else /* NV_PRESERVES_UV */
2199 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2200 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2201 /* Small enough to preserve all bits. */
2202 (void)SvIOKp_on(sv);
2204 SvIVX(sv) = I_V(SvNVX(sv));
2205 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2207 /* Assumption: first non-preserved integer is < IV_MAX,
2208 this NV is in the preserved range, therefore: */
2209 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2211 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);
2214 sv_2iuv_non_preserve (sv, numtype);
2215 #endif /* NV_PRESERVES_UV */
2220 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2221 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2224 if (SvTYPE(sv) < SVt_IV)
2225 /* Typically the caller expects that sv_any is not NULL now. */
2226 sv_upgrade(sv, SVt_IV);
2230 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2231 PTR2UV(sv),SvUVX(sv)));
2232 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2236 Perl_sv_2nv(pTHX_ register SV *sv)
2240 if (SvGMAGICAL(sv)) {
2244 if (SvPOKp(sv) && SvLEN(sv)) {
2245 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2247 return Atof(SvPVX(sv));
2251 return (NV)SvUVX(sv);
2253 return (NV)SvIVX(sv);
2256 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2257 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2263 if (SvTHINKFIRST(sv)) {
2266 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2267 (SvRV(tmpstr) != SvRV(sv)))
2268 return SvNV(tmpstr);
2269 return PTR2NV(SvRV(sv));
2271 if (SvREADONLY(sv) && SvFAKE(sv)) {
2272 sv_force_normal(sv);
2274 if (SvREADONLY(sv) && !SvOK(sv)) {
2275 if (ckWARN(WARN_UNINITIALIZED))
2280 if (SvTYPE(sv) < SVt_NV) {
2281 if (SvTYPE(sv) == SVt_IV)
2282 sv_upgrade(sv, SVt_PVNV);
2284 sv_upgrade(sv, SVt_NV);
2285 #if defined(USE_LONG_DOUBLE)
2287 STORE_NUMERIC_LOCAL_SET_STANDARD();
2288 PerlIO_printf(Perl_debug_log,
2289 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2290 PTR2UV(sv), SvNVX(sv));
2291 RESTORE_NUMERIC_LOCAL();
2295 STORE_NUMERIC_LOCAL_SET_STANDARD();
2296 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2297 PTR2UV(sv), SvNVX(sv));
2298 RESTORE_NUMERIC_LOCAL();
2302 else if (SvTYPE(sv) < SVt_PVNV)
2303 sv_upgrade(sv, SVt_PVNV);
2305 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2307 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2308 #ifdef NV_PRESERVES_UV
2311 /* Only set the public NV OK flag if this NV preserves the IV */
2312 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2313 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2314 : (SvIVX(sv) == I_V(SvNVX(sv))))
2320 else if (SvPOKp(sv) && SvLEN(sv)) {
2321 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2323 SvNVX(sv) = Atof(SvPVX(sv));
2324 #ifdef NV_PRESERVES_UV
2327 /* Only set the public NV OK flag if this NV preserves the value in
2328 the PV at least as well as an IV/UV would.
2329 Not sure how to do this 100% reliably. */
2330 /* if that shift count is out of range then Configure's test is
2331 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2333 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2334 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2335 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2336 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2337 /* Definitely too large/small to fit in an integer, so no loss
2338 of precision going to integer in the future via NV */
2341 /* Is it something we can run through strtol etc (ie no
2342 trailing exponent part)? */
2343 int numtype = looks_like_number(sv);
2344 /* XXX probably should cache this if called above */
2347 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2348 /* Can't use strtol etc to convert this string, so don't try */
2351 sv_2inuv_non_preserve (sv, numtype);
2353 #endif /* NV_PRESERVES_UV */
2356 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2358 if (SvTYPE(sv) < SVt_NV)
2359 /* Typically the caller expects that sv_any is not NULL now. */
2360 /* XXX Ilya implies that this is a bug in callers that assume this
2361 and ideally should be fixed. */
2362 sv_upgrade(sv, SVt_NV);
2365 #if defined(USE_LONG_DOUBLE)
2367 STORE_NUMERIC_LOCAL_SET_STANDARD();
2368 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2369 PTR2UV(sv), SvNVX(sv));
2370 RESTORE_NUMERIC_LOCAL();
2374 STORE_NUMERIC_LOCAL_SET_STANDARD();
2375 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2376 PTR2UV(sv), SvNVX(sv));
2377 RESTORE_NUMERIC_LOCAL();
2384 S_asIV(pTHX_ SV *sv)
2386 I32 numtype = looks_like_number(sv);
2389 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2390 return Atol(SvPVX(sv));
2392 if (ckWARN(WARN_NUMERIC))
2395 d = Atof(SvPVX(sv));
2400 S_asUV(pTHX_ SV *sv)
2402 I32 numtype = looks_like_number(sv);
2405 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2406 return Strtoul(SvPVX(sv), Null(char**), 10);
2409 if (ckWARN(WARN_NUMERIC))
2412 return U_V(Atof(SvPVX(sv)));
2416 * Returns a combination of (advisory only - can get false negatives)
2417 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2418 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2419 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2420 * 0 if does not look like number.
2422 * (atol and strtol stop when they hit a decimal point. strtol will return
2423 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2424 * do this, and vendors have had 11 years to get it right.
2425 * However, will try to make it still work with only atol
2427 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2428 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2429 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2430 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2431 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2432 * IS_NUMBER_NOT_INT saw "." or "e"
2434 * IS_NUMBER_INFINITY
2438 =for apidoc looks_like_number
2440 Test if an the content of an SV looks like a number (or is a
2441 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2442 issue a non-numeric warning), even if your atof() doesn't grok them.
2448 Perl_looks_like_number(pTHX_ SV *sv)
2451 register char *send;
2452 register char *sbegin;
2453 register char *nbegin;
2457 #ifdef USE_LOCALE_NUMERIC
2458 bool specialradix = FALSE;
2465 else if (SvPOKp(sv))
2466 sbegin = SvPV(sv, len);
2469 send = sbegin + len;
2476 numtype = IS_NUMBER_NEG;
2483 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2484 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2485 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2486 * will need (int)atof().
2489 /* next must be digit or the radix separator or beginning of infinity */
2493 } while (isDIGIT(*s));
2495 /* Aaargh. long long really is irritating.
2496 In the gospel according to ANSI 1989, it is an axiom that "long"
2497 is the longest integer type, and that if you don't know how long
2498 something is you can cast it to long, and nothing will be lost
2499 (except possibly speed of execution if long is slower than the
2501 Now, one can't be sure if the old rules apply, or long long
2502 (or some other newfangled thing) is actually longer than the
2503 (formerly) longest thing.
2505 /* This lot will work for 64 bit *as long as* either
2506 either long is 64 bit
2507 or we can find both strtol/strtoq and strtoul/strtouq
2508 If not, we really should refuse to let the user use 64 bit IVs
2509 By "64 bit" I really mean IVs that don't get preserved by NVs
2510 It also should work for 128 bit IVs. Can any lend me a machine to
2513 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2514 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2515 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2516 ? sizeof(long) : sizeof (IV))*8-1))
2517 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2519 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2520 digit less (IV_MAX= 9223372036854775807,
2521 UV_MAX= 18446744073709551615) so be cautious */
2522 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2525 #ifdef USE_LOCALE_NUMERIC
2526 || (specialradix = IS_NUMERIC_RADIX(s))
2529 #ifdef USE_LOCALE_NUMERIC
2531 s += SvCUR(PL_numeric_radix);
2535 numtype |= IS_NUMBER_NOT_INT;
2536 while (isDIGIT(*s)) /* optional digits after the radix */
2541 #ifdef USE_LOCALE_NUMERIC
2542 || (specialradix = IS_NUMERIC_RADIX(s))
2545 #ifdef USE_LOCALE_NUMERIC
2547 s += SvCUR(PL_numeric_radix);
2551 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2552 /* no digits before the radix means we need digits after it */
2556 } while (isDIGIT(*s));
2561 else if (*s == 'I' || *s == 'i') {
2562 s++; if (*s != 'N' && *s != 'n') return 0;
2563 s++; if (*s != 'F' && *s != 'f') return 0;
2564 s++; if (*s == 'I' || *s == 'i') {
2565 s++; if (*s != 'N' && *s != 'n') return 0;
2566 s++; if (*s != 'I' && *s != 'i') return 0;
2567 s++; if (*s != 'T' && *s != 't') return 0;
2568 s++; if (*s != 'Y' && *s != 'y') return 0;
2577 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2578 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2580 /* we can have an optional exponent part */
2581 if (*s == 'e' || *s == 'E') {
2582 numtype &= IS_NUMBER_NEG;
2583 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2585 if (*s == '+' || *s == '-')
2590 } while (isDIGIT(*s));
2600 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2601 return IS_NUMBER_TO_INT_BY_ATOL;
2606 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2609 return sv_2pv(sv, &n_a);
2612 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2614 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2616 char *ptr = buf + TYPE_CHARS(UV);
2630 *--ptr = '0' + (uv % 10);
2639 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2644 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2645 char *tmpbuf = tbuf;
2651 if (SvGMAGICAL(sv)) {
2659 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2661 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2666 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2671 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2672 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2679 if (SvTHINKFIRST(sv)) {
2682 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2683 (SvRV(tmpstr) != SvRV(sv)))
2684 return SvPV(tmpstr,*lp);
2691 switch (SvTYPE(sv)) {
2693 if ( ((SvFLAGS(sv) &
2694 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2695 == (SVs_OBJECT|SVs_RMG))
2696 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2697 && (mg = mg_find(sv, 'r'))) {
2698 regexp *re = (regexp *)mg->mg_obj;
2701 char *fptr = "msix";
2706 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2708 while((ch = *fptr++)) {
2710 reflags[left++] = ch;
2713 reflags[right--] = ch;
2718 reflags[left] = '-';
2722 mg->mg_len = re->prelen + 4 + left;
2723 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2724 Copy("(?", mg->mg_ptr, 2, char);
2725 Copy(reflags, mg->mg_ptr+2, left, char);
2726 Copy(":", mg->mg_ptr+left+2, 1, char);
2727 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2728 mg->mg_ptr[mg->mg_len - 1] = ')';
2729 mg->mg_ptr[mg->mg_len] = 0;
2731 PL_reginterp_cnt += re->program[0].next_off;
2743 case SVt_PVBM: if (SvROK(sv))
2746 s = "SCALAR"; break;
2747 case SVt_PVLV: s = "LVALUE"; break;
2748 case SVt_PVAV: s = "ARRAY"; break;
2749 case SVt_PVHV: s = "HASH"; break;
2750 case SVt_PVCV: s = "CODE"; break;
2751 case SVt_PVGV: s = "GLOB"; break;
2752 case SVt_PVFM: s = "FORMAT"; break;
2753 case SVt_PVIO: s = "IO"; break;
2754 default: s = "UNKNOWN"; break;
2758 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2761 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2767 if (SvREADONLY(sv) && !SvOK(sv)) {
2768 if (ckWARN(WARN_UNINITIALIZED))
2774 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2775 /* I'm assuming that if both IV and NV are equally valid then
2776 converting the IV is going to be more efficient */
2777 U32 isIOK = SvIOK(sv);
2778 U32 isUIOK = SvIsUV(sv);
2779 char buf[TYPE_CHARS(UV)];
2782 if (SvTYPE(sv) < SVt_PVIV)
2783 sv_upgrade(sv, SVt_PVIV);
2785 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2787 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2788 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2789 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2790 SvCUR_set(sv, ebuf - ptr);
2800 else if (SvNOKp(sv)) {
2801 if (SvTYPE(sv) < SVt_PVNV)
2802 sv_upgrade(sv, SVt_PVNV);
2803 /* The +20 is pure guesswork. Configure test needed. --jhi */
2804 SvGROW(sv, NV_DIG + 20);
2806 olderrno = errno; /* some Xenix systems wipe out errno here */
2808 if (SvNVX(sv) == 0.0)
2809 (void)strcpy(s,"0");
2813 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2816 #ifdef FIXNEGATIVEZERO
2817 if (*s == '-' && s[1] == '0' && !s[2])
2827 if (ckWARN(WARN_UNINITIALIZED)
2828 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2831 if (SvTYPE(sv) < SVt_PV)
2832 /* Typically the caller expects that sv_any is not NULL now. */
2833 sv_upgrade(sv, SVt_PV);
2836 *lp = s - SvPVX(sv);
2839 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2840 PTR2UV(sv),SvPVX(sv)));
2844 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2845 /* Sneaky stuff here */
2849 tsv = newSVpv(tmpbuf, 0);
2865 len = strlen(tmpbuf);
2867 #ifdef FIXNEGATIVEZERO
2868 if (len == 2 && t[0] == '-' && t[1] == '0') {
2873 (void)SvUPGRADE(sv, SVt_PV);
2875 s = SvGROW(sv, len + 1);
2884 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2887 return sv_2pvbyte(sv, &n_a);
2891 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2893 sv_utf8_downgrade(sv,0);
2894 return SvPV(sv,*lp);
2898 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2901 return sv_2pvutf8(sv, &n_a);
2905 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2907 sv_utf8_upgrade(sv);
2908 return SvPV(sv,*lp);
2911 /* This function is only called on magical items */
2913 Perl_sv_2bool(pTHX_ register SV *sv)
2922 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2923 (SvRV(tmpsv) != SvRV(sv)))
2924 return SvTRUE(tmpsv);
2925 return SvRV(sv) != 0;
2928 register XPV* Xpvtmp;
2929 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2930 (*Xpvtmp->xpv_pv > '0' ||
2931 Xpvtmp->xpv_cur > 1 ||
2932 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2939 return SvIVX(sv) != 0;
2942 return SvNVX(sv) != 0.0;
2950 =for apidoc sv_utf8_upgrade
2952 Convert the PV of an SV to its UTF8-encoded form.
2953 Forces the SV to string form it it is not already.
2954 Always sets the SvUTF8 flag to avoid future validity checks even
2955 if all the bytes have hibit clear.
2961 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2970 (void) SvPV_nolen(sv);
2975 if (SvREADONLY(sv) && SvFAKE(sv)) {
2976 sv_force_normal(sv);
2979 /* This function could be much more efficient if we had a FLAG in SVs
2980 * to signal if there are any hibit chars in the PV.
2981 * Given that there isn't make loop fast as possible
2983 s = (U8 *) SvPVX(sv);
2984 e = (U8 *) SvEND(sv);
2988 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
2994 len = SvCUR(sv) + 1; /* Plus the \0 */
2995 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
2996 SvCUR(sv) = len - 1;
2998 Safefree(s); /* No longer using what was there before. */
2999 SvLEN(sv) = len; /* No longer know the real size. */
3001 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3007 =for apidoc sv_utf8_downgrade
3009 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3010 This may not be possible if the PV contains non-byte encoding characters;
3011 if this is the case, either returns false or, if C<fail_ok> is not
3018 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3020 if (SvPOK(sv) && SvUTF8(sv)) {
3025 if (SvREADONLY(sv) && SvFAKE(sv))
3026 sv_force_normal(sv);
3027 s = (U8 *) SvPV(sv, len);
3028 if (!utf8_to_bytes(s, &len)) {
3031 #ifdef USE_BYTES_DOWNGRADES
3034 U8 *e = (U8 *) SvEND(sv);
3037 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3038 if (first && ch > 255) {
3040 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3041 PL_op_desc[PL_op->op_type]);
3043 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3050 len = (d - (U8 *) SvPVX(sv));
3055 Perl_croak(aTHX_ "Wide character in %s",
3056 PL_op_desc[PL_op->op_type]);
3058 Perl_croak(aTHX_ "Wide character");
3069 =for apidoc sv_utf8_encode
3071 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3072 flag so that it looks like octets again. Used as a building block
3073 for encode_utf8 in Encode.xs
3079 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3081 (void) sv_utf8_upgrade(sv);
3086 =for apidoc sv_utf8_decode
3088 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3089 turn of SvUTF8 if needed so that we see characters. Used as a building block
3090 for decode_utf8 in Encode.xs
3098 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3104 /* The octets may have got themselves encoded - get them back as bytes */
3105 if (!sv_utf8_downgrade(sv, TRUE))
3108 /* it is actually just a matter of turning the utf8 flag on, but
3109 * we want to make sure everything inside is valid utf8 first.
3111 c = (U8 *) SvPVX(sv);
3112 if (!is_utf8_string(c, SvCUR(sv)+1))
3114 e = (U8 *) SvEND(sv);
3117 if (!UTF8_IS_INVARIANT(ch)) {
3127 /* Note: sv_setsv() should not be called with a source string that needs
3128 * to be reused, since it may destroy the source string if it is marked
3133 =for apidoc sv_setsv
3135 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3136 The source SV may be destroyed if it is mortal. Does not handle 'set'
3137 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3144 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3146 register U32 sflags;
3152 SV_CHECK_THINKFIRST(dstr);
3154 sstr = &PL_sv_undef;
3155 stype = SvTYPE(sstr);
3156 dtype = SvTYPE(dstr);
3160 /* There's a lot of redundancy below but we're going for speed here */
3165 if (dtype != SVt_PVGV) {
3166 (void)SvOK_off(dstr);
3174 sv_upgrade(dstr, SVt_IV);
3177 sv_upgrade(dstr, SVt_PVNV);
3181 sv_upgrade(dstr, SVt_PVIV);
3184 (void)SvIOK_only(dstr);
3185 SvIVX(dstr) = SvIVX(sstr);
3188 if (SvTAINTED(sstr))
3199 sv_upgrade(dstr, SVt_NV);
3204 sv_upgrade(dstr, SVt_PVNV);
3207 SvNVX(dstr) = SvNVX(sstr);
3208 (void)SvNOK_only(dstr);
3209 if (SvTAINTED(sstr))
3217 sv_upgrade(dstr, SVt_RV);
3218 else if (dtype == SVt_PVGV &&
3219 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3222 if (GvIMPORTED(dstr) != GVf_IMPORTED
3223 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3225 GvIMPORTED_on(dstr);
3236 sv_upgrade(dstr, SVt_PV);
3239 if (dtype < SVt_PVIV)
3240 sv_upgrade(dstr, SVt_PVIV);
3243 if (dtype < SVt_PVNV)
3244 sv_upgrade(dstr, SVt_PVNV);
3251 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3252 PL_op_name[PL_op->op_type]);
3254 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3258 if (dtype <= SVt_PVGV) {
3260 if (dtype != SVt_PVGV) {
3261 char *name = GvNAME(sstr);
3262 STRLEN len = GvNAMELEN(sstr);
3263 sv_upgrade(dstr, SVt_PVGV);
3264 sv_magic(dstr, dstr, '*', Nullch, 0);
3265 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3266 GvNAME(dstr) = savepvn(name, len);
3267 GvNAMELEN(dstr) = len;
3268 SvFAKE_on(dstr); /* can coerce to non-glob */
3270 /* ahem, death to those who redefine active sort subs */
3271 else if (PL_curstackinfo->si_type == PERLSI_SORT
3272 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3273 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3276 #ifdef GV_SHARED_CHECK
3277 if (GvSHARED((GV*)dstr)) {
3278 Perl_croak(aTHX_ PL_no_modify);
3282 (void)SvOK_off(dstr);
3283 GvINTRO_off(dstr); /* one-shot flag */
3285 GvGP(dstr) = gp_ref(GvGP(sstr));
3286 if (SvTAINTED(sstr))
3288 if (GvIMPORTED(dstr) != GVf_IMPORTED
3289 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3291 GvIMPORTED_on(dstr);
3299 if (SvGMAGICAL(sstr)) {
3301 if (SvTYPE(sstr) != stype) {
3302 stype = SvTYPE(sstr);
3303 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3307 if (stype == SVt_PVLV)
3308 (void)SvUPGRADE(dstr, SVt_PVNV);
3310 (void)SvUPGRADE(dstr, stype);
3313 sflags = SvFLAGS(sstr);
3315 if (sflags & SVf_ROK) {
3316 if (dtype >= SVt_PV) {
3317 if (dtype == SVt_PVGV) {
3318 SV *sref = SvREFCNT_inc(SvRV(sstr));
3320 int intro = GvINTRO(dstr);
3322 #ifdef GV_SHARED_CHECK
3323 if (GvSHARED((GV*)dstr)) {
3324 Perl_croak(aTHX_ PL_no_modify);
3331 GvINTRO_off(dstr); /* one-shot flag */
3332 Newz(602,gp, 1, GP);
3333 GvGP(dstr) = gp_ref(gp);
3334 GvSV(dstr) = NEWSV(72,0);
3335 GvLINE(dstr) = CopLINE(PL_curcop);
3336 GvEGV(dstr) = (GV*)dstr;
3339 switch (SvTYPE(sref)) {
3342 SAVESPTR(GvAV(dstr));
3344 dref = (SV*)GvAV(dstr);
3345 GvAV(dstr) = (AV*)sref;
3346 if (!GvIMPORTED_AV(dstr)
3347 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3349 GvIMPORTED_AV_on(dstr);
3354 SAVESPTR(GvHV(dstr));
3356 dref = (SV*)GvHV(dstr);
3357 GvHV(dstr) = (HV*)sref;
3358 if (!GvIMPORTED_HV(dstr)
3359 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3361 GvIMPORTED_HV_on(dstr);
3366 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3367 SvREFCNT_dec(GvCV(dstr));
3368 GvCV(dstr) = Nullcv;
3369 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3370 PL_sub_generation++;
3372 SAVESPTR(GvCV(dstr));
3375 dref = (SV*)GvCV(dstr);
3376 if (GvCV(dstr) != (CV*)sref) {
3377 CV* cv = GvCV(dstr);
3379 if (!GvCVGEN((GV*)dstr) &&
3380 (CvROOT(cv) || CvXSUB(cv)))
3382 /* ahem, death to those who redefine
3383 * active sort subs */
3384 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3385 PL_sortcop == CvSTART(cv))
3387 "Can't redefine active sort subroutine %s",
3388 GvENAME((GV*)dstr));
3389 /* Redefining a sub - warning is mandatory if
3390 it was a const and its value changed. */
3391 if (ckWARN(WARN_REDEFINE)
3393 && (!CvCONST((CV*)sref)
3394 || sv_cmp(cv_const_sv(cv),
3395 cv_const_sv((CV*)sref)))))
3397 Perl_warner(aTHX_ WARN_REDEFINE,
3399 ? "Constant subroutine %s redefined"
3400 : "Subroutine %s redefined",
3401 GvENAME((GV*)dstr));
3404 cv_ckproto(cv, (GV*)dstr,
3405 SvPOK(sref) ? SvPVX(sref) : Nullch);
3407 GvCV(dstr) = (CV*)sref;
3408 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3409 GvASSUMECV_on(dstr);
3410 PL_sub_generation++;
3412 if (!GvIMPORTED_CV(dstr)
3413 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3415 GvIMPORTED_CV_on(dstr);
3420 SAVESPTR(GvIOp(dstr));
3422 dref = (SV*)GvIOp(dstr);
3423 GvIOp(dstr) = (IO*)sref;
3427 SAVESPTR(GvFORM(dstr));
3429 dref = (SV*)GvFORM(dstr);
3430 GvFORM(dstr) = (CV*)sref;
3434 SAVESPTR(GvSV(dstr));
3436 dref = (SV*)GvSV(dstr);
3438 if (!GvIMPORTED_SV(dstr)
3439 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3441 GvIMPORTED_SV_on(dstr);
3449 if (SvTAINTED(sstr))
3454 (void)SvOOK_off(dstr); /* backoff */
3456 Safefree(SvPVX(dstr));
3457 SvLEN(dstr)=SvCUR(dstr)=0;
3460 (void)SvOK_off(dstr);
3461 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3463 if (sflags & SVp_NOK) {
3465 /* Only set the public OK flag if the source has public OK. */
3466 if (sflags & SVf_NOK)
3467 SvFLAGS(dstr) |= SVf_NOK;
3468 SvNVX(dstr) = SvNVX(sstr);
3470 if (sflags & SVp_IOK) {
3471 (void)SvIOKp_on(dstr);
3472 if (sflags & SVf_IOK)
3473 SvFLAGS(dstr) |= SVf_IOK;
3474 if (sflags & SVf_IVisUV)
3476 SvIVX(dstr) = SvIVX(sstr);
3478 if (SvAMAGIC(sstr)) {
3482 else if (sflags & SVp_POK) {
3485 * Check to see if we can just swipe the string. If so, it's a
3486 * possible small lose on short strings, but a big win on long ones.
3487 * It might even be a win on short strings if SvPVX(dstr)
3488 * has to be allocated and SvPVX(sstr) has to be freed.
3491 if (SvTEMP(sstr) && /* slated for free anyway? */
3492 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3493 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3494 SvLEN(sstr) && /* and really is a string */
3495 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3497 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3499 SvFLAGS(dstr) &= ~SVf_OOK;
3500 Safefree(SvPVX(dstr) - SvIVX(dstr));
3502 else if (SvLEN(dstr))
3503 Safefree(SvPVX(dstr));
3505 (void)SvPOK_only(dstr);
3506 SvPV_set(dstr, SvPVX(sstr));
3507 SvLEN_set(dstr, SvLEN(sstr));
3508 SvCUR_set(dstr, SvCUR(sstr));
3511 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3512 SvPV_set(sstr, Nullch);
3517 else { /* have to copy actual string */
3518 STRLEN len = SvCUR(sstr);
3520 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3521 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3522 SvCUR_set(dstr, len);
3523 *SvEND(dstr) = '\0';
3524 (void)SvPOK_only(dstr);
3526 if (sflags & SVf_UTF8)
3529 if (sflags & SVp_NOK) {
3531 if (sflags & SVf_NOK)
3532 SvFLAGS(dstr) |= SVf_NOK;
3533 SvNVX(dstr) = SvNVX(sstr);
3535 if (sflags & SVp_IOK) {
3536 (void)SvIOKp_on(dstr);
3537 if (sflags & SVf_IOK)
3538 SvFLAGS(dstr) |= SVf_IOK;
3539 if (sflags & SVf_IVisUV)
3541 SvIVX(dstr) = SvIVX(sstr);
3544 else if (sflags & SVp_IOK) {
3545 if (sflags & SVf_IOK)
3546 (void)SvIOK_only(dstr);
3548 (void)SvOK_off(dstr);
3549 (void)SvIOKp_on(dstr);
3551 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3552 if (sflags & SVf_IVisUV)
3554 SvIVX(dstr) = SvIVX(sstr);
3555 if (sflags & SVp_NOK) {
3556 if (sflags & SVf_NOK)
3557 (void)SvNOK_on(dstr);
3559 (void)SvNOKp_on(dstr);
3560 SvNVX(dstr) = SvNVX(sstr);
3563 else if (sflags & SVp_NOK) {
3564 if (sflags & SVf_NOK)
3565 (void)SvNOK_only(dstr);
3567 (void)SvOK_off(dstr);
3570 SvNVX(dstr) = SvNVX(sstr);
3573 if (dtype == SVt_PVGV) {
3574 if (ckWARN(WARN_MISC))
3575 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3578 (void)SvOK_off(dstr);
3580 if (SvTAINTED(sstr))
3585 =for apidoc sv_setsv_mg
3587 Like C<sv_setsv>, but also handles 'set' magic.
3593 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3595 sv_setsv(dstr,sstr);
3600 =for apidoc sv_setpvn
3602 Copies a string into an SV. The C<len> parameter indicates the number of
3603 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3609 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3611 register char *dptr;
3613 SV_CHECK_THINKFIRST(sv);
3619 /* len is STRLEN which is unsigned, need to copy to signed */
3623 (void)SvUPGRADE(sv, SVt_PV);
3625 SvGROW(sv, len + 1);
3627 Move(ptr,dptr,len,char);
3630 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3635 =for apidoc sv_setpvn_mg
3637 Like C<sv_setpvn>, but also handles 'set' magic.
3643 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3645 sv_setpvn(sv,ptr,len);
3650 =for apidoc sv_setpv
3652 Copies a string into an SV. The string must be null-terminated. Does not
3653 handle 'set' magic. See C<sv_setpv_mg>.
3659 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3661 register STRLEN len;
3663 SV_CHECK_THINKFIRST(sv);
3669 (void)SvUPGRADE(sv, SVt_PV);
3671 SvGROW(sv, len + 1);
3672 Move(ptr,SvPVX(sv),len+1,char);
3674 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3679 =for apidoc sv_setpv_mg
3681 Like C<sv_setpv>, but also handles 'set' magic.
3687 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3694 =for apidoc sv_usepvn
3696 Tells an SV to use C<ptr> to find its string value. Normally the string is
3697 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3698 The C<ptr> should point to memory that was allocated by C<malloc>. The
3699 string length, C<len>, must be supplied. This function will realloc the
3700 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3701 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3702 See C<sv_usepvn_mg>.
3708 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3710 SV_CHECK_THINKFIRST(sv);
3711 (void)SvUPGRADE(sv, SVt_PV);
3716 (void)SvOOK_off(sv);
3717 if (SvPVX(sv) && SvLEN(sv))
3718 Safefree(SvPVX(sv));
3719 Renew(ptr, len+1, char);
3722 SvLEN_set(sv, len+1);
3724 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3729 =for apidoc sv_usepvn_mg
3731 Like C<sv_usepvn>, but also handles 'set' magic.
3737 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3739 sv_usepvn(sv,ptr,len);
3744 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3746 if (SvREADONLY(sv)) {
3748 char *pvx = SvPVX(sv);
3749 STRLEN len = SvCUR(sv);
3750 U32 hash = SvUVX(sv);
3751 SvGROW(sv, len + 1);
3752 Move(pvx,SvPVX(sv),len,char);
3756 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3758 else if (PL_curcop != &PL_compiling)
3759 Perl_croak(aTHX_ PL_no_modify);
3762 sv_unref_flags(sv, flags);
3763 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3768 Perl_sv_force_normal(pTHX_ register SV *sv)
3770 sv_force_normal_flags(sv, 0);
3776 Efficient removal of characters from the beginning of the string buffer.
3777 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3778 the string buffer. The C<ptr> becomes the first character of the adjusted
3785 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3789 register STRLEN delta;
3791 if (!ptr || !SvPOKp(sv))
3793 SV_CHECK_THINKFIRST(sv);
3794 if (SvTYPE(sv) < SVt_PVIV)
3795 sv_upgrade(sv,SVt_PVIV);
3798 if (!SvLEN(sv)) { /* make copy of shared string */
3799 char *pvx = SvPVX(sv);
3800 STRLEN len = SvCUR(sv);
3801 SvGROW(sv, len + 1);
3802 Move(pvx,SvPVX(sv),len,char);
3806 SvFLAGS(sv) |= SVf_OOK;
3808 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3809 delta = ptr - SvPVX(sv);
3817 =for apidoc sv_catpvn
3819 Concatenates the string onto the end of the string which is in the SV. The
3820 C<len> indicates number of bytes to copy. If the SV has the UTF8
3821 status set, then the bytes appended should be valid UTF8.
3822 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3828 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3833 junk = SvPV_force(sv, tlen);
3834 SvGROW(sv, tlen + len + 1);
3837 Move(ptr,SvPVX(sv)+tlen,len,char);
3840 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3845 =for apidoc sv_catpvn_mg
3847 Like C<sv_catpvn>, but also handles 'set' magic.
3853 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3855 sv_catpvn(sv,ptr,len);
3860 =for apidoc sv_catsv
3862 Concatenates the string from SV C<ssv> onto the end of the string in
3863 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3864 not 'set' magic. See C<sv_catsv_mg>.
3869 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3875 if ((spv = SvPV(ssv, slen))) {
3876 bool dutf8 = DO_UTF8(dsv);
3877 bool sutf8 = DO_UTF8(ssv);
3880 sv_catpvn(dsv,spv,slen);
3883 /* Not modifying source SV, so taking a temporary copy. */
3884 SV* csv = sv_2mortal(newSVsv(ssv));
3888 sv_utf8_upgrade(csv);
3889 cpv = SvPV(csv,clen);
3890 sv_catpvn(dsv,cpv,clen);
3893 sv_utf8_upgrade(dsv);
3894 sv_catpvn(dsv,spv,slen);
3895 SvUTF8_on(dsv); /* If dsv has no wide characters. */
3902 =for apidoc sv_catsv_mg
3904 Like C<sv_catsv>, but also handles 'set' magic.
3910 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3917 =for apidoc sv_catpv
3919 Concatenates the string onto the end of the string which is in the SV.
3920 If the SV has the UTF8 status set, then the bytes appended should be
3921 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3926 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3928 register STRLEN len;
3934 junk = SvPV_force(sv, tlen);
3936 SvGROW(sv, tlen + len + 1);
3939 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3941 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3946 =for apidoc sv_catpv_mg
3948 Like C<sv_catpv>, but also handles 'set' magic.
3954 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3961 Perl_newSV(pTHX_ STRLEN len)
3967 sv_upgrade(sv, SVt_PV);
3968 SvGROW(sv, len + 1);
3973 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3976 =for apidoc sv_magic
3978 Adds magic to an SV.
3984 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3988 if (SvREADONLY(sv)) {
3989 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3990 Perl_croak(aTHX_ PL_no_modify);
3992 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3993 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4000 (void)SvUPGRADE(sv, SVt_PVMG);
4002 Newz(702,mg, 1, MAGIC);
4003 mg->mg_moremagic = SvMAGIC(sv);
4006 /* Some magic sontains a reference loop, where the sv and object refer to
4007 each other. To prevent a avoid a reference loop that would prevent such
4008 objects being freed, we look for such loops and if we find one we avoid
4009 incrementing the object refcount. */
4010 if (!obj || obj == sv || how == '#' || how == 'r' ||
4011 (SvTYPE(obj) == SVt_PVGV &&
4012 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4013 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4014 GvFORM(obj) == (CV*)sv)))
4019 mg->mg_obj = SvREFCNT_inc(obj);
4020 mg->mg_flags |= MGf_REFCOUNTED;
4023 mg->mg_len = namlen;
4026 mg->mg_ptr = savepvn(name, namlen);
4027 else if (namlen == HEf_SVKEY)
4028 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4033 mg->mg_virtual = &PL_vtbl_sv;
4036 mg->mg_virtual = &PL_vtbl_amagic;
4039 mg->mg_virtual = &PL_vtbl_amagicelem;
4042 mg->mg_virtual = &PL_vtbl_ovrld;
4045 mg->mg_virtual = &PL_vtbl_bm;
4048 mg->mg_virtual = &PL_vtbl_regdata;
4051 mg->mg_virtual = &PL_vtbl_regdatum;
4054 mg->mg_virtual = &PL_vtbl_env;
4057 mg->mg_virtual = &PL_vtbl_fm;
4060 mg->mg_virtual = &PL_vtbl_envelem;
4063 mg->mg_virtual = &PL_vtbl_mglob;
4066 mg->mg_virtual = &PL_vtbl_isa;
4069 mg->mg_virtual = &PL_vtbl_isaelem;
4072 mg->mg_virtual = &PL_vtbl_nkeys;
4079 mg->mg_virtual = &PL_vtbl_dbline;
4083 mg->mg_virtual = &PL_vtbl_mutex;
4085 #endif /* USE_THREADS */
4086 #ifdef USE_LOCALE_COLLATE
4088 mg->mg_virtual = &PL_vtbl_collxfrm;
4090 #endif /* USE_LOCALE_COLLATE */
4092 mg->mg_virtual = &PL_vtbl_pack;
4096 mg->mg_virtual = &PL_vtbl_packelem;
4099 mg->mg_virtual = &PL_vtbl_regexp;
4102 mg->mg_virtual = &PL_vtbl_sig;
4105 mg->mg_virtual = &PL_vtbl_sigelem;
4108 mg->mg_virtual = &PL_vtbl_taint;
4112 mg->mg_virtual = &PL_vtbl_uvar;
4115 mg->mg_virtual = &PL_vtbl_vec;
4118 mg->mg_virtual = &PL_vtbl_substr;
4121 mg->mg_virtual = &PL_vtbl_defelem;
4124 mg->mg_virtual = &PL_vtbl_glob;
4127 mg->mg_virtual = &PL_vtbl_arylen;
4130 mg->mg_virtual = &PL_vtbl_pos;
4133 mg->mg_virtual = &PL_vtbl_backref;
4135 case '~': /* Reserved for use by extensions not perl internals. */
4136 /* Useful for attaching extension internal data to perl vars. */
4137 /* Note that multiple extensions may clash if magical scalars */
4138 /* etc holding private data from one are passed to another. */
4142 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4146 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4150 =for apidoc sv_unmagic
4152 Removes magic from an SV.
4158 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4162 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4165 for (mg = *mgp; mg; mg = *mgp) {
4166 if (mg->mg_type == type) {
4167 MGVTBL* vtbl = mg->mg_virtual;
4168 *mgp = mg->mg_moremagic;
4169 if (vtbl && vtbl->svt_free)
4170 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4171 if (mg->mg_ptr && mg->mg_type != 'g') {
4172 if (mg->mg_len >= 0)
4173 Safefree(mg->mg_ptr);
4174 else if (mg->mg_len == HEf_SVKEY)
4175 SvREFCNT_dec((SV*)mg->mg_ptr);
4177 if (mg->mg_flags & MGf_REFCOUNTED)
4178 SvREFCNT_dec(mg->mg_obj);
4182 mgp = &mg->mg_moremagic;
4186 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4193 =for apidoc sv_rvweaken
4201 Perl_sv_rvweaken(pTHX_ SV *sv)
4204 if (!SvOK(sv)) /* let undefs pass */
4207 Perl_croak(aTHX_ "Can't weaken a nonreference");
4208 else if (SvWEAKREF(sv)) {
4209 if (ckWARN(WARN_MISC))
4210 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4214 sv_add_backref(tsv, sv);
4221 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4225 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4226 av = (AV*)mg->mg_obj;
4229 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4230 SvREFCNT_dec(av); /* for sv_magic */
4236 S_sv_del_backref(pTHX_ SV *sv)
4243 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4244 Perl_croak(aTHX_ "panic: del_backref");
4245 av = (AV *)mg->mg_obj;
4250 svp[i] = &PL_sv_undef; /* XXX */
4257 =for apidoc sv_insert
4259 Inserts a string at the specified offset/length within the SV. Similar to
4260 the Perl substr() function.
4266 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4270 register char *midend;
4271 register char *bigend;
4277 Perl_croak(aTHX_ "Can't modify non-existent substring");
4278 SvPV_force(bigstr, curlen);
4279 (void)SvPOK_only_UTF8(bigstr);
4280 if (offset + len > curlen) {
4281 SvGROW(bigstr, offset+len+1);
4282 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4283 SvCUR_set(bigstr, offset+len);
4287 i = littlelen - len;
4288 if (i > 0) { /* string might grow */
4289 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4290 mid = big + offset + len;
4291 midend = bigend = big + SvCUR(bigstr);
4294 while (midend > mid) /* shove everything down */
4295 *--bigend = *--midend;
4296 Move(little,big+offset,littlelen,char);
4302 Move(little,SvPVX(bigstr)+offset,len,char);
4307 big = SvPVX(bigstr);
4310 bigend = big + SvCUR(bigstr);
4312 if (midend > bigend)
4313 Perl_croak(aTHX_ "panic: sv_insert");
4315 if (mid - big > bigend - midend) { /* faster to shorten from end */
4317 Move(little, mid, littlelen,char);
4320 i = bigend - midend;
4322 Move(midend, mid, i,char);
4326 SvCUR_set(bigstr, mid - big);
4329 else if ((i = mid - big)) { /* faster from front */
4330 midend -= littlelen;
4332 sv_chop(bigstr,midend-i);
4337 Move(little, mid, littlelen,char);
4339 else if (littlelen) {
4340 midend -= littlelen;
4341 sv_chop(bigstr,midend);
4342 Move(little,midend,littlelen,char);
4345 sv_chop(bigstr,midend);
4351 =for apidoc sv_replace
4353 Make the first argument a copy of the second, then delete the original.
4359 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4361 U32 refcnt = SvREFCNT(sv);
4362 SV_CHECK_THINKFIRST(sv);
4363 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4364 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4365 if (SvMAGICAL(sv)) {
4369 sv_upgrade(nsv, SVt_PVMG);
4370 SvMAGIC(nsv) = SvMAGIC(sv);
4371 SvFLAGS(nsv) |= SvMAGICAL(sv);
4377 assert(!SvREFCNT(sv));
4378 StructCopy(nsv,sv,SV);
4379 SvREFCNT(sv) = refcnt;
4380 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4385 =for apidoc sv_clear
4387 Clear an SV, making it empty. Does not free the memory used by the SV
4394 Perl_sv_clear(pTHX_ register SV *sv)
4398 assert(SvREFCNT(sv) == 0);
4401 if (PL_defstash) { /* Still have a symbol table? */
4406 Zero(&tmpref, 1, SV);
4407 sv_upgrade(&tmpref, SVt_RV);
4409 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4410 SvREFCNT(&tmpref) = 1;
4413 stash = SvSTASH(sv);
4414 destructor = StashHANDLER(stash,DESTROY);
4417 PUSHSTACKi(PERLSI_DESTROY);
4418 SvRV(&tmpref) = SvREFCNT_inc(sv);
4423 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4429 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4431 del_XRV(SvANY(&tmpref));
4434 if (PL_in_clean_objs)
4435 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4437 /* DESTROY gave object new lease on life */
4443 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4444 SvOBJECT_off(sv); /* Curse the object. */
4445 if (SvTYPE(sv) != SVt_PVIO)
4446 --PL_sv_objcount; /* XXX Might want something more general */
4449 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4452 switch (SvTYPE(sv)) {
4455 IoIFP(sv) != PerlIO_stdin() &&
4456 IoIFP(sv) != PerlIO_stdout() &&
4457 IoIFP(sv) != PerlIO_stderr())
4459 io_close((IO*)sv, FALSE);
4461 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4462 PerlDir_close(IoDIRP(sv));
4463 IoDIRP(sv) = (DIR*)NULL;
4464 Safefree(IoTOP_NAME(sv));
4465 Safefree(IoFMT_NAME(sv));
4466 Safefree(IoBOTTOM_NAME(sv));
4481 SvREFCNT_dec(LvTARG(sv));
4485 Safefree(GvNAME(sv));
4486 /* cannot decrease stash refcount yet, as we might recursively delete
4487 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4488 of stash until current sv is completely gone.
4489 -- JohnPC, 27 Mar 1998 */
4490 stash = GvSTASH(sv);
4496 (void)SvOOK_off(sv);
4504 SvREFCNT_dec(SvRV(sv));
4506 else if (SvPVX(sv) && SvLEN(sv))
4507 Safefree(SvPVX(sv));
4508 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4509 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4521 switch (SvTYPE(sv)) {
4537 del_XPVIV(SvANY(sv));
4540 del_XPVNV(SvANY(sv));
4543 del_XPVMG(SvANY(sv));
4546 del_XPVLV(SvANY(sv));
4549 del_XPVAV(SvANY(sv));
4552 del_XPVHV(SvANY(sv));
4555 del_XPVCV(SvANY(sv));
4558 del_XPVGV(SvANY(sv));
4559 /* code duplication for increased performance. */
4560 SvFLAGS(sv) &= SVf_BREAK;
4561 SvFLAGS(sv) |= SVTYPEMASK;
4562 /* decrease refcount of the stash that owns this GV, if any */
4564 SvREFCNT_dec(stash);
4565 return; /* not break, SvFLAGS reset already happened */
4567 del_XPVBM(SvANY(sv));
4570 del_XPVFM(SvANY(sv));
4573 del_XPVIO(SvANY(sv));
4576 SvFLAGS(sv) &= SVf_BREAK;
4577 SvFLAGS(sv) |= SVTYPEMASK;
4581 Perl_sv_newref(pTHX_ SV *sv)
4584 ATOMIC_INC(SvREFCNT(sv));
4591 Free the memory used by an SV.
4597 Perl_sv_free(pTHX_ SV *sv)
4599 int refcount_is_zero;
4603 if (SvREFCNT(sv) == 0) {
4604 if (SvFLAGS(sv) & SVf_BREAK)
4606 if (PL_in_clean_all) /* All is fair */
4608 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4609 /* make sure SvREFCNT(sv)==0 happens very seldom */
4610 SvREFCNT(sv) = (~(U32)0)/2;
4613 if (ckWARN_d(WARN_INTERNAL))
4614 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4617 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4618 if (!refcount_is_zero)
4622 if (ckWARN_d(WARN_DEBUGGING))
4623 Perl_warner(aTHX_ WARN_DEBUGGING,
4624 "Attempt to free temp prematurely: SV 0x%"UVxf,
4629 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4630 /* make sure SvREFCNT(sv)==0 happens very seldom */
4631 SvREFCNT(sv) = (~(U32)0)/2;
4642 Returns the length of the string in the SV. See also C<SvCUR>.
4648 Perl_sv_len(pTHX_ register SV *sv)
4657 len = mg_length(sv);
4659 junk = SvPV(sv, len);
4664 =for apidoc sv_len_utf8
4666 Returns the number of characters in the string in an SV, counting wide
4667 UTF8 bytes as a single character.
4673 Perl_sv_len_utf8(pTHX_ register SV *sv)
4679 return mg_length(sv);
4683 U8 *s = (U8*)SvPV(sv, len);
4685 return Perl_utf8_length(aTHX_ s, s + len);
4690 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4695 I32 uoffset = *offsetp;
4701 start = s = (U8*)SvPV(sv, len);
4703 while (s < send && uoffset--)
4707 *offsetp = s - start;
4711 while (s < send && ulen--)
4721 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4730 s = (U8*)SvPV(sv, len);
4732 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4733 send = s + *offsetp;
4737 /* Call utf8n_to_uvchr() to validate the sequence */
4738 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4753 Returns a boolean indicating whether the strings in the two SVs are
4760 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4774 pv1 = SvPV(sv1, cur1);
4781 pv2 = SvPV(sv2, cur2);
4783 /* do not utf8ize the comparands as a side-effect */
4784 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4785 bool is_utf8 = TRUE;
4786 /* UTF-8ness differs */
4787 if (PL_hints & HINT_UTF8_DISTINCT)
4791 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4792 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4797 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4798 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4803 /* Downgrade not possible - cannot be eq */
4809 eq = memEQ(pv1, pv2, cur1);
4820 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4821 string in C<sv1> is less than, equal to, or greater than the string in
4828 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4833 bool pv1tmp = FALSE;
4834 bool pv2tmp = FALSE;
4841 pv1 = SvPV(sv1, cur1);
4848 pv2 = SvPV(sv2, cur2);
4850 /* do not utf8ize the comparands as a side-effect */
4851 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4852 if (PL_hints & HINT_UTF8_DISTINCT)
4853 return SvUTF8(sv1) ? 1 : -1;
4856 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4860 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4866 cmp = cur2 ? -1 : 0;
4870 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4873 cmp = retval < 0 ? -1 : 1;
4874 } else if (cur1 == cur2) {
4877 cmp = cur1 < cur2 ? -1 : 1;
4890 =for apidoc sv_cmp_locale
4892 Compares the strings in two SVs in a locale-aware manner. See
4899 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4901 #ifdef USE_LOCALE_COLLATE
4907 if (PL_collation_standard)
4911 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4913 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4915 if (!pv1 || !len1) {
4926 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4929 return retval < 0 ? -1 : 1;
4932 * When the result of collation is equality, that doesn't mean
4933 * that there are no differences -- some locales exclude some
4934 * characters from consideration. So to avoid false equalities,
4935 * we use the raw string as a tiebreaker.
4941 #endif /* USE_LOCALE_COLLATE */
4943 return sv_cmp(sv1, sv2);
4946 #ifdef USE_LOCALE_COLLATE
4948 * Any scalar variable may carry an 'o' magic that contains the
4949 * scalar data of the variable transformed to such a format that
4950 * a normal memory comparison can be used to compare the data
4951 * according to the locale settings.
4954 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4958 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4959 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4964 Safefree(mg->mg_ptr);
4966 if ((xf = mem_collxfrm(s, len, &xlen))) {
4967 if (SvREADONLY(sv)) {
4970 return xf + sizeof(PL_collation_ix);
4973 sv_magic(sv, 0, 'o', 0, 0);
4974 mg = mg_find(sv, 'o');
4987 if (mg && mg->mg_ptr) {
4989 return mg->mg_ptr + sizeof(PL_collation_ix);
4997 #endif /* USE_LOCALE_COLLATE */
5002 Get a line from the filehandle and store it into the SV, optionally
5003 appending to the currently-stored string.
5009 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5013 register STDCHAR rslast;
5014 register STDCHAR *bp;
5018 SV_CHECK_THINKFIRST(sv);
5019 (void)SvUPGRADE(sv, SVt_PV);
5023 if (RsSNARF(PL_rs)) {
5027 else if (RsRECORD(PL_rs)) {
5028 I32 recsize, bytesread;
5031 /* Grab the size of the record we're getting */
5032 recsize = SvIV(SvRV(PL_rs));
5033 (void)SvPOK_only(sv); /* Validate pointer */
5034 buffer = SvGROW(sv, recsize + 1);
5037 /* VMS wants read instead of fread, because fread doesn't respect */
5038 /* RMS record boundaries. This is not necessarily a good thing to be */
5039 /* doing, but we've got no other real choice */
5040 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5042 bytesread = PerlIO_read(fp, buffer, recsize);
5044 SvCUR_set(sv, bytesread);
5045 buffer[bytesread] = '\0';
5046 if (PerlIO_isutf8(fp))
5050 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5052 else if (RsPARA(PL_rs)) {
5057 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5058 if (PerlIO_isutf8(fp)) {
5059 rsptr = SvPVutf8(PL_rs, rslen);
5062 if (SvUTF8(PL_rs)) {
5063 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5064 Perl_croak(aTHX_ "Wide character in $/");
5067 rsptr = SvPV(PL_rs, rslen);
5071 rslast = rslen ? rsptr[rslen - 1] : '\0';
5073 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5074 do { /* to make sure file boundaries work right */
5077 i = PerlIO_getc(fp);
5081 PerlIO_ungetc(fp,i);
5087 /* See if we know enough about I/O mechanism to cheat it ! */
5089 /* This used to be #ifdef test - it is made run-time test for ease
5090 of abstracting out stdio interface. One call should be cheap
5091 enough here - and may even be a macro allowing compile
5095 if (PerlIO_fast_gets(fp)) {
5098 * We're going to steal some values from the stdio struct
5099 * and put EVERYTHING in the innermost loop into registers.
5101 register STDCHAR *ptr;
5105 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5106 /* An ungetc()d char is handled separately from the regular
5107 * buffer, so we getc() it back out and stuff it in the buffer.
5109 i = PerlIO_getc(fp);
5110 if (i == EOF) return 0;
5111 *(--((*fp)->_ptr)) = (unsigned char) i;
5115 /* Here is some breathtakingly efficient cheating */
5117 cnt = PerlIO_get_cnt(fp); /* get count into register */
5118 (void)SvPOK_only(sv); /* validate pointer */
5119 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5120 if (cnt > 80 && SvLEN(sv) > append) {
5121 shortbuffered = cnt - SvLEN(sv) + append + 1;
5122 cnt -= shortbuffered;
5126 /* remember that cnt can be negative */
5127 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5132 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5133 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5134 DEBUG_P(PerlIO_printf(Perl_debug_log,
5135 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5136 DEBUG_P(PerlIO_printf(Perl_debug_log,
5137 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5138 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5139 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5144 while (cnt > 0) { /* this | eat */
5146 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5147 goto thats_all_folks; /* screams | sed :-) */
5151 Copy(ptr, bp, cnt, char); /* this | eat */
5152 bp += cnt; /* screams | dust */
5153 ptr += cnt; /* louder | sed :-) */
5158 if (shortbuffered) { /* oh well, must extend */
5159 cnt = shortbuffered;
5161 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5163 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5164 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5168 DEBUG_P(PerlIO_printf(Perl_debug_log,
5169 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5170 PTR2UV(ptr),(long)cnt));
5171 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5172 DEBUG_P(PerlIO_printf(Perl_debug_log,
5173 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5174 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5175 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5176 /* This used to call 'filbuf' in stdio form, but as that behaves like
5177 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5178 another abstraction. */
5179 i = PerlIO_getc(fp); /* get more characters */
5180 DEBUG_P(PerlIO_printf(Perl_debug_log,
5181 "Screamer: post: 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 cnt = PerlIO_get_cnt(fp);
5185 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5186 DEBUG_P(PerlIO_printf(Perl_debug_log,
5187 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5189 if (i == EOF) /* all done for ever? */
5190 goto thats_really_all_folks;
5192 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5194 SvGROW(sv, bpx + cnt + 2);
5195 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5197 *bp++ = i; /* store character from PerlIO_getc */
5199 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5200 goto thats_all_folks;
5204 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5205 memNE((char*)bp - rslen, rsptr, rslen))
5206 goto screamer; /* go back to the fray */
5207 thats_really_all_folks:
5209 cnt += shortbuffered;
5210 DEBUG_P(PerlIO_printf(Perl_debug_log,
5211 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5212 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5213 DEBUG_P(PerlIO_printf(Perl_debug_log,
5214 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5215 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5216 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5218 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5219 DEBUG_P(PerlIO_printf(Perl_debug_log,
5220 "Screamer: done, len=%ld, string=|%.*s|\n",
5221 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5226 /*The big, slow, and stupid way */
5229 /* Need to work around EPOC SDK features */
5230 /* On WINS: MS VC5 generates calls to _chkstk, */
5231 /* if a `large' stack frame is allocated */
5232 /* gcc on MARM does not generate calls like these */
5238 register STDCHAR *bpe = buf + sizeof(buf);
5240 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5241 ; /* keep reading */
5245 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5246 /* Accomodate broken VAXC compiler, which applies U8 cast to
5247 * both args of ?: operator, causing EOF to change into 255
5249 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5253 sv_catpvn(sv, (char *) buf, cnt);
5255 sv_setpvn(sv, (char *) buf, cnt);
5257 if (i != EOF && /* joy */
5259 SvCUR(sv) < rslen ||
5260 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5264 * If we're reading from a TTY and we get a short read,
5265 * indicating that the user hit his EOF character, we need
5266 * to notice it now, because if we try to read from the TTY
5267 * again, the EOF condition will disappear.
5269 * The comparison of cnt to sizeof(buf) is an optimization
5270 * that prevents unnecessary calls to feof().
5274 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5279 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5280 while (i != EOF) { /* to make sure file boundaries work right */
5281 i = PerlIO_getc(fp);
5283 PerlIO_ungetc(fp,i);
5289 if (PerlIO_isutf8(fp))
5294 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5301 Auto-increment of the value in the SV.
5307 Perl_sv_inc(pTHX_ register SV *sv)
5316 if (SvTHINKFIRST(sv)) {
5317 if (SvREADONLY(sv)) {
5318 if (PL_curcop != &PL_compiling)
5319 Perl_croak(aTHX_ PL_no_modify);
5323 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5325 i = PTR2IV(SvRV(sv));
5330 flags = SvFLAGS(sv);
5331 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5332 /* It's (privately or publicly) a float, but not tested as an
5333 integer, so test it to see. */
5335 flags = SvFLAGS(sv);
5337 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5338 /* It's publicly an integer, or privately an integer-not-float */
5341 if (SvUVX(sv) == UV_MAX)
5342 sv_setnv(sv, (NV)UV_MAX + 1.0);
5344 (void)SvIOK_only_UV(sv);
5347 if (SvIVX(sv) == IV_MAX)
5348 sv_setuv(sv, (UV)IV_MAX + 1);
5350 (void)SvIOK_only(sv);
5356 if (flags & SVp_NOK) {
5357 (void)SvNOK_only(sv);
5362 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5363 if ((flags & SVTYPEMASK) < SVt_PVIV)
5364 sv_upgrade(sv, SVt_IV);
5365 (void)SvIOK_only(sv);
5370 while (isALPHA(*d)) d++;
5371 while (isDIGIT(*d)) d++;
5373 #ifdef PERL_PRESERVE_IVUV
5374 /* Got to punt this an an integer if needs be, but we don't issue
5375 warnings. Probably ought to make the sv_iv_please() that does
5376 the conversion if possible, and silently. */
5377 I32 numtype = looks_like_number(sv);
5378 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5379 /* Need to try really hard to see if it's an integer.
5380 9.22337203685478e+18 is an integer.
5381 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5382 so $a="9.22337203685478e+18"; $a+0; $a++
5383 needs to be the same as $a="9.22337203685478e+18"; $a++
5390 /* sv_2iv *should* have made this an NV */
5391 if (flags & SVp_NOK) {
5392 (void)SvNOK_only(sv);
5396 /* I don't think we can get here. Maybe I should assert this
5397 And if we do get here I suspect that sv_setnv will croak. NWC
5399 #if defined(USE_LONG_DOUBLE)
5400 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",
5401 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5403 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5404 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5407 #endif /* PERL_PRESERVE_IVUV */
5408 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5412 while (d >= SvPVX(sv)) {
5420 /* MKS: The original code here died if letters weren't consecutive.
5421 * at least it didn't have to worry about non-C locales. The
5422 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5423 * arranged in order (although not consecutively) and that only
5424 * [A-Za-z] are accepted by isALPHA in the C locale.
5426 if (*d != 'z' && *d != 'Z') {
5427 do { ++*d; } while (!isALPHA(*d));
5430 *(d--) -= 'z' - 'a';
5435 *(d--) -= 'z' - 'a' + 1;
5439 /* oh,oh, the number grew */
5440 SvGROW(sv, SvCUR(sv) + 2);
5442 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5453 Auto-decrement of the value in the SV.
5459 Perl_sv_dec(pTHX_ register SV *sv)
5467 if (SvTHINKFIRST(sv)) {
5468 if (SvREADONLY(sv)) {
5469 if (PL_curcop != &PL_compiling)
5470 Perl_croak(aTHX_ PL_no_modify);
5474 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5476 i = PTR2IV(SvRV(sv));
5481 /* Unlike sv_inc we don't have to worry about string-never-numbers
5482 and keeping them magic. But we mustn't warn on punting */
5483 flags = SvFLAGS(sv);
5484 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5485 /* It's publicly an integer, or privately an integer-not-float */
5488 if (SvUVX(sv) == 0) {
5489 (void)SvIOK_only(sv);
5493 (void)SvIOK_only_UV(sv);
5497 if (SvIVX(sv) == IV_MIN)
5498 sv_setnv(sv, (NV)IV_MIN - 1.0);
5500 (void)SvIOK_only(sv);
5506 if (flags & SVp_NOK) {
5508 (void)SvNOK_only(sv);
5511 if (!(flags & SVp_POK)) {
5512 if ((flags & SVTYPEMASK) < SVt_PVNV)
5513 sv_upgrade(sv, SVt_NV);
5515 (void)SvNOK_only(sv);
5518 #ifdef PERL_PRESERVE_IVUV
5520 I32 numtype = looks_like_number(sv);
5521 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5522 /* Need to try really hard to see if it's an integer.
5523 9.22337203685478e+18 is an integer.
5524 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5525 so $a="9.22337203685478e+18"; $a+0; $a--
5526 needs to be the same as $a="9.22337203685478e+18"; $a--
5533 /* sv_2iv *should* have made this an NV */
5534 if (flags & SVp_NOK) {
5535 (void)SvNOK_only(sv);
5539 /* I don't think we can get here. Maybe I should assert this
5540 And if we do get here I suspect that sv_setnv will croak. NWC
5542 #if defined(USE_LONG_DOUBLE)
5543 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",
5544 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5546 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5547 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5551 #endif /* PERL_PRESERVE_IVUV */
5552 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5556 =for apidoc sv_mortalcopy
5558 Creates a new SV which is a copy of the original SV. The new SV is marked
5564 /* Make a string that will exist for the duration of the expression
5565 * evaluation. Actually, it may have to last longer than that, but
5566 * hopefully we won't free it until it has been assigned to a
5567 * permanent location. */
5570 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5575 sv_setsv(sv,oldstr);
5577 PL_tmps_stack[++PL_tmps_ix] = sv;
5583 =for apidoc sv_newmortal
5585 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5591 Perl_sv_newmortal(pTHX)
5596 SvFLAGS(sv) = SVs_TEMP;
5598 PL_tmps_stack[++PL_tmps_ix] = sv;
5603 =for apidoc sv_2mortal
5605 Marks an SV as mortal. The SV will be destroyed when the current context
5611 /* same thing without the copying */
5614 Perl_sv_2mortal(pTHX_ register SV *sv)
5618 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5621 PL_tmps_stack[++PL_tmps_ix] = sv;
5629 Creates a new SV and copies a string into it. The reference count for the
5630 SV is set to 1. If C<len> is zero, Perl will compute the length using
5631 strlen(). For efficiency, consider using C<newSVpvn> instead.
5637 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5644 sv_setpvn(sv,s,len);
5649 =for apidoc newSVpvn
5651 Creates a new SV and copies a string into it. The reference count for the
5652 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5653 string. You are responsible for ensuring that the source string is at least
5660 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5665 sv_setpvn(sv,s,len);
5670 =for apidoc newSVpvn_share
5672 Creates a new SV and populates it with a string from
5673 the string table. Turns on READONLY and FAKE.
5674 The idea here is that as string table is used for shared hash
5675 keys these strings will have SvPVX == HeKEY and hash lookup
5676 will avoid string compare.
5682 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5685 bool is_utf8 = FALSE;
5690 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5691 STRLEN tmplen = len;
5692 /* See the note in hv.c:hv_fetch() --jhi */
5693 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5697 PERL_HASH(hash, src, len);
5699 sv_upgrade(sv, SVt_PVIV);
5700 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5712 #if defined(PERL_IMPLICIT_CONTEXT)
5714 Perl_newSVpvf_nocontext(const char* pat, ...)
5719 va_start(args, pat);
5720 sv = vnewSVpvf(pat, &args);
5727 =for apidoc newSVpvf
5729 Creates a new SV an initialize it with the string formatted like
5736 Perl_newSVpvf(pTHX_ const char* pat, ...)
5740 va_start(args, pat);
5741 sv = vnewSVpvf(pat, &args);
5747 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5751 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5758 Creates a new SV and copies a floating point value into it.
5759 The reference count for the SV is set to 1.
5765 Perl_newSVnv(pTHX_ NV n)
5777 Creates a new SV and copies an integer into it. The reference count for the
5784 Perl_newSViv(pTHX_ IV i)
5796 Creates a new SV and copies an unsigned integer into it.
5797 The reference count for the SV is set to 1.
5803 Perl_newSVuv(pTHX_ UV u)
5813 =for apidoc newRV_noinc
5815 Creates an RV wrapper for an SV. The reference count for the original
5816 SV is B<not> incremented.
5822 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5827 sv_upgrade(sv, SVt_RV);
5834 /* newRV_inc is #defined to newRV in sv.h */
5836 Perl_newRV(pTHX_ SV *tmpRef)
5838 return newRV_noinc(SvREFCNT_inc(tmpRef));
5844 Creates a new SV which is an exact duplicate of the original SV.
5849 /* make an exact duplicate of old */
5852 Perl_newSVsv(pTHX_ register SV *old)
5858 if (SvTYPE(old) == SVTYPEMASK) {
5859 if (ckWARN_d(WARN_INTERNAL))
5860 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5875 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5883 char todo[PERL_UCHAR_MAX+1];
5888 if (!*s) { /* reset ?? searches */
5889 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5890 pm->op_pmdynflags &= ~PMdf_USED;
5895 /* reset variables */
5897 if (!HvARRAY(stash))
5900 Zero(todo, 256, char);
5902 i = (unsigned char)*s;
5906 max = (unsigned char)*s++;
5907 for ( ; i <= max; i++) {
5910 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5911 for (entry = HvARRAY(stash)[i];
5913 entry = HeNEXT(entry))
5915 if (!todo[(U8)*HeKEY(entry)])
5917 gv = (GV*)HeVAL(entry);
5919 if (SvTHINKFIRST(sv)) {
5920 if (!SvREADONLY(sv) && SvROK(sv))
5925 if (SvTYPE(sv) >= SVt_PV) {
5927 if (SvPVX(sv) != Nullch)
5934 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5936 #ifdef USE_ENVIRON_ARRAY
5938 environ[0] = Nullch;
5947 Perl_sv_2io(pTHX_ SV *sv)
5953 switch (SvTYPE(sv)) {
5961 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5965 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5967 return sv_2io(SvRV(sv));
5968 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5974 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5981 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5988 return *gvp = Nullgv, Nullcv;
5989 switch (SvTYPE(sv)) {
6008 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6009 tryAMAGICunDEREF(to_cv);
6012 if (SvTYPE(sv) == SVt_PVCV) {
6021 Perl_croak(aTHX_ "Not a subroutine reference");
6026 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6032 if (lref && !GvCVu(gv)) {
6035 tmpsv = NEWSV(704,0);
6036 gv_efullname3(tmpsv, gv, Nullch);
6037 /* XXX this is probably not what they think they're getting.
6038 * It has the same effect as "sub name;", i.e. just a forward
6040 newSUB(start_subparse(FALSE, 0),
6041 newSVOP(OP_CONST, 0, tmpsv),
6046 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6055 Returns true if the SV has a true value by Perl's rules.
6061 Perl_sv_true(pTHX_ register SV *sv)
6067 if ((tXpv = (XPV*)SvANY(sv)) &&
6068 (tXpv->xpv_cur > 1 ||
6069 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6076 return SvIVX(sv) != 0;
6079 return SvNVX(sv) != 0.0;
6081 return sv_2bool(sv);
6087 Perl_sv_iv(pTHX_ register SV *sv)
6091 return (IV)SvUVX(sv);
6098 Perl_sv_uv(pTHX_ register SV *sv)
6103 return (UV)SvIVX(sv);
6109 Perl_sv_nv(pTHX_ register SV *sv)
6117 Perl_sv_pv(pTHX_ SV *sv)
6124 return sv_2pv(sv, &n_a);
6128 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6134 return sv_2pv(sv, lp);
6138 =for apidoc sv_pvn_force
6140 Get a sensible string out of the SV somehow.
6146 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6150 if (SvTHINKFIRST(sv) && !SvROK(sv))
6151 sv_force_normal(sv);
6157 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6158 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6159 PL_op_name[PL_op->op_type]);
6163 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6168 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6169 SvGROW(sv, len + 1);
6170 Move(s,SvPVX(sv),len,char);
6175 SvPOK_on(sv); /* validate pointer */
6177 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6178 PTR2UV(sv),SvPVX(sv)));
6185 Perl_sv_pvbyte(pTHX_ SV *sv)
6187 sv_utf8_downgrade(sv,0);
6192 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6194 sv_utf8_downgrade(sv,0);
6195 return sv_pvn(sv,lp);
6199 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6201 sv_utf8_downgrade(sv,0);
6202 return sv_pvn_force(sv,lp);
6206 Perl_sv_pvutf8(pTHX_ SV *sv)
6208 sv_utf8_upgrade(sv);
6213 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6215 sv_utf8_upgrade(sv);
6216 return sv_pvn(sv,lp);
6220 =for apidoc sv_pvutf8n_force
6222 Get a sensible UTF8-encoded string out of the SV somehow. See
6229 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6231 sv_utf8_upgrade(sv);
6232 return sv_pvn_force(sv,lp);
6236 =for apidoc sv_reftype
6238 Returns a string describing what the SV is a reference to.
6244 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6246 if (ob && SvOBJECT(sv))
6247 return HvNAME(SvSTASH(sv));
6249 switch (SvTYPE(sv)) {
6263 case SVt_PVLV: return "LVALUE";
6264 case SVt_PVAV: return "ARRAY";
6265 case SVt_PVHV: return "HASH";
6266 case SVt_PVCV: return "CODE";
6267 case SVt_PVGV: return "GLOB";
6268 case SVt_PVFM: return "FORMAT";
6269 case SVt_PVIO: return "IO";
6270 default: return "UNKNOWN";
6276 =for apidoc sv_isobject
6278 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6279 object. If the SV is not an RV, or if the object is not blessed, then this
6286 Perl_sv_isobject(pTHX_ SV *sv)
6303 Returns a boolean indicating whether the SV is blessed into the specified
6304 class. This does not check for subtypes; use C<sv_derived_from> to verify
6305 an inheritance relationship.
6311 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6323 return strEQ(HvNAME(SvSTASH(sv)), name);
6329 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6330 it will be upgraded to one. If C<classname> is non-null then the new SV will
6331 be blessed in the specified package. The new SV is returned and its
6332 reference count is 1.
6338 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6344 SV_CHECK_THINKFIRST(rv);
6347 if (SvTYPE(rv) >= SVt_PVMG) {
6348 U32 refcnt = SvREFCNT(rv);
6352 SvREFCNT(rv) = refcnt;
6355 if (SvTYPE(rv) < SVt_RV)
6356 sv_upgrade(rv, SVt_RV);
6357 else if (SvTYPE(rv) > SVt_RV) {
6358 (void)SvOOK_off(rv);
6359 if (SvPVX(rv) && SvLEN(rv))
6360 Safefree(SvPVX(rv));
6370 HV* stash = gv_stashpv(classname, TRUE);
6371 (void)sv_bless(rv, stash);
6377 =for apidoc sv_setref_pv
6379 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6380 argument will be upgraded to an RV. That RV will be modified to point to
6381 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6382 into the SV. The C<classname> argument indicates the package for the
6383 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6384 will be returned and will have a reference count of 1.
6386 Do not use with other Perl types such as HV, AV, SV, CV, because those
6387 objects will become corrupted by the pointer copy process.
6389 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6395 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6398 sv_setsv(rv, &PL_sv_undef);
6402 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6407 =for apidoc sv_setref_iv
6409 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6410 argument will be upgraded to an RV. That RV will be modified to point to
6411 the new SV. The C<classname> argument indicates the package for the
6412 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6413 will be returned and will have a reference count of 1.
6419 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6421 sv_setiv(newSVrv(rv,classname), iv);
6426 =for apidoc sv_setref_uv
6428 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6429 argument will be upgraded to an RV. That RV will be modified to point to
6430 the new SV. The C<classname> argument indicates the package for the
6431 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6432 will be returned and will have a reference count of 1.
6438 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6440 sv_setuv(newSVrv(rv,classname), uv);
6445 =for apidoc sv_setref_nv
6447 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6448 argument will be upgraded to an RV. That RV will be modified to point to
6449 the new SV. The C<classname> argument indicates the package for the
6450 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6451 will be returned and will have a reference count of 1.
6457 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6459 sv_setnv(newSVrv(rv,classname), nv);
6464 =for apidoc sv_setref_pvn
6466 Copies a string into a new SV, optionally blessing the SV. The length of the
6467 string must be specified with C<n>. The C<rv> argument will be upgraded to
6468 an RV. That RV will be modified to point to the new SV. The C<classname>
6469 argument indicates the package for the blessing. Set C<classname> to
6470 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6471 a reference count of 1.
6473 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6479 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6481 sv_setpvn(newSVrv(rv,classname), pv, n);
6486 =for apidoc sv_bless
6488 Blesses an SV into a specified package. The SV must be an RV. The package
6489 must be designated by its stash (see C<gv_stashpv()>). The reference count
6490 of the SV is unaffected.
6496 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6500 Perl_croak(aTHX_ "Can't bless non-reference value");
6502 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6503 if (SvREADONLY(tmpRef))
6504 Perl_croak(aTHX_ PL_no_modify);
6505 if (SvOBJECT(tmpRef)) {
6506 if (SvTYPE(tmpRef) != SVt_PVIO)
6508 SvREFCNT_dec(SvSTASH(tmpRef));
6511 SvOBJECT_on(tmpRef);
6512 if (SvTYPE(tmpRef) != SVt_PVIO)
6514 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6515 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6526 S_sv_unglob(pTHX_ SV *sv)
6530 assert(SvTYPE(sv) == SVt_PVGV);
6535 SvREFCNT_dec(GvSTASH(sv));
6536 GvSTASH(sv) = Nullhv;
6538 sv_unmagic(sv, '*');
6539 Safefree(GvNAME(sv));
6542 /* need to keep SvANY(sv) in the right arena */
6543 xpvmg = new_XPVMG();
6544 StructCopy(SvANY(sv), xpvmg, XPVMG);
6545 del_XPVGV(SvANY(sv));
6548 SvFLAGS(sv) &= ~SVTYPEMASK;
6549 SvFLAGS(sv) |= SVt_PVMG;
6553 =for apidoc sv_unref_flags
6555 Unsets the RV status of the SV, and decrements the reference count of
6556 whatever was being referenced by the RV. This can almost be thought of
6557 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6558 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6559 (otherwise the decrementing is conditional on the reference count being
6560 different from one or the reference being a readonly SV).
6567 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6571 if (SvWEAKREF(sv)) {
6579 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6581 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6582 sv_2mortal(rv); /* Schedule for freeing later */
6586 =for apidoc sv_unref
6588 Unsets the RV status of the SV, and decrements the reference count of
6589 whatever was being referenced by the RV. This can almost be thought of
6590 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6591 being zero. See C<SvROK_off>.
6597 Perl_sv_unref(pTHX_ SV *sv)
6599 sv_unref_flags(sv, 0);
6603 Perl_sv_taint(pTHX_ SV *sv)
6605 sv_magic((sv), Nullsv, 't', Nullch, 0);
6609 Perl_sv_untaint(pTHX_ SV *sv)
6611 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6612 MAGIC *mg = mg_find(sv, 't');
6619 Perl_sv_tainted(pTHX_ SV *sv)
6621 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6622 MAGIC *mg = mg_find(sv, 't');
6623 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6630 =for apidoc sv_setpviv
6632 Copies an integer into the given SV, also updating its string value.
6633 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6639 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6641 char buf[TYPE_CHARS(UV)];
6643 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6645 sv_setpvn(sv, ptr, ebuf - ptr);
6650 =for apidoc sv_setpviv_mg
6652 Like C<sv_setpviv>, but also handles 'set' magic.
6658 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6660 char buf[TYPE_CHARS(UV)];
6662 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6664 sv_setpvn(sv, ptr, ebuf - ptr);
6668 #if defined(PERL_IMPLICIT_CONTEXT)
6670 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6674 va_start(args, pat);
6675 sv_vsetpvf(sv, pat, &args);
6681 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6685 va_start(args, pat);
6686 sv_vsetpvf_mg(sv, pat, &args);
6692 =for apidoc sv_setpvf
6694 Processes its arguments like C<sprintf> and sets an SV to the formatted
6695 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6701 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6704 va_start(args, pat);
6705 sv_vsetpvf(sv, pat, &args);
6710 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6712 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6716 =for apidoc sv_setpvf_mg
6718 Like C<sv_setpvf>, but also handles 'set' magic.
6724 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6727 va_start(args, pat);
6728 sv_vsetpvf_mg(sv, pat, &args);
6733 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6735 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6739 #if defined(PERL_IMPLICIT_CONTEXT)
6741 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6745 va_start(args, pat);
6746 sv_vcatpvf(sv, pat, &args);
6751 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6755 va_start(args, pat);
6756 sv_vcatpvf_mg(sv, pat, &args);
6762 =for apidoc sv_catpvf
6764 Processes its arguments like C<sprintf> and appends the formatted
6765 output to an SV. If the appended data contains "wide" characters
6766 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6767 and characters >255 formatted with %c), the original SV might get
6768 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6769 C<SvSETMAGIC()> must typically be called after calling this function
6770 to handle 'set' magic.
6775 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6778 va_start(args, pat);
6779 sv_vcatpvf(sv, pat, &args);
6784 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6786 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6790 =for apidoc sv_catpvf_mg
6792 Like C<sv_catpvf>, but also handles 'set' magic.
6798 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6801 va_start(args, pat);
6802 sv_vcatpvf_mg(sv, pat, &args);
6807 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6809 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6814 =for apidoc sv_vsetpvfn
6816 Works like C<vcatpvfn> but copies the text into the SV instead of
6823 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6825 sv_setpvn(sv, "", 0);
6826 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6830 S_expect_number(pTHX_ char** pattern)
6833 switch (**pattern) {
6834 case '1': case '2': case '3':
6835 case '4': case '5': case '6':
6836 case '7': case '8': case '9':
6837 while (isDIGIT(**pattern))
6838 var = var * 10 + (*(*pattern)++ - '0');
6842 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6845 =for apidoc sv_vcatpvfn
6847 Processes its arguments like C<vsprintf> and appends the formatted output
6848 to an SV. Uses an array of SVs if the C style variable argument list is
6849 missing (NULL). When running with taint checks enabled, indicates via
6850 C<maybe_tainted> if results are untrustworthy (often due to the use of
6857 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6864 static char nullstr[] = "(null)";
6867 /* no matter what, this is a string now */
6868 (void)SvPV_force(sv, origlen);
6870 /* special-case "", "%s", and "%_" */
6873 if (patlen == 2 && pat[0] == '%') {
6877 char *s = va_arg(*args, char*);
6878 sv_catpv(sv, s ? s : nullstr);
6880 else if (svix < svmax) {
6881 sv_catsv(sv, *svargs);
6882 if (DO_UTF8(*svargs))
6888 argsv = va_arg(*args, SV*);
6889 sv_catsv(sv, argsv);
6894 /* See comment on '_' below */
6899 patend = (char*)pat + patlen;
6900 for (p = (char*)pat; p < patend; p = q) {
6903 bool vectorize = FALSE;
6904 bool vectorarg = FALSE;
6905 bool vec_utf = FALSE;
6911 bool has_precis = FALSE;
6913 bool is_utf = FALSE;
6916 U8 utf8buf[UTF8_MAXLEN+1];
6917 STRLEN esignlen = 0;
6919 char *eptr = Nullch;
6921 /* Times 4: a decimal digit takes more than 3 binary digits.
6922 * NV_DIG: mantissa takes than many decimal digits.
6923 * Plus 32: Playing safe. */
6924 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6925 /* large enough for "%#.#f" --chip */
6926 /* what about long double NVs? --jhi */
6929 U8 *vecstr = Null(U8*);
6941 STRLEN dotstrlen = 1;
6942 I32 efix = 0; /* explicit format parameter index */
6943 I32 ewix = 0; /* explicit width index */
6944 I32 epix = 0; /* explicit precision index */
6945 I32 evix = 0; /* explicit vector index */
6946 bool asterisk = FALSE;
6948 /* echo everything up to the next format specification */
6949 for (q = p; q < patend && *q != '%'; ++q) ;
6951 sv_catpvn(sv, p, q - p);
6958 We allow format specification elements in this order:
6959 \d+\$ explicit format parameter index
6961 \*?(\d+\$)?v vector with optional (optionally specified) arg
6962 \d+|\*(\d+\$)? width using optional (optionally specified) arg
6963 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
6965 [%bcdefginopsux_DFOUX] format (mandatory)
6967 if (EXPECT_NUMBER(q, width)) {
7008 if (EXPECT_NUMBER(q, ewix))
7017 if ((vectorarg = asterisk)) {
7027 EXPECT_NUMBER(q, width);
7032 vecsv = va_arg(*args, SV*);
7034 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7035 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7036 dotstr = SvPVx(vecsv, dotstrlen);
7041 vecsv = va_arg(*args, SV*);
7042 vecstr = (U8*)SvPVx(vecsv,veclen);
7043 vec_utf = DO_UTF8(vecsv);
7045 else if (efix ? efix <= svmax : svix < svmax) {
7046 vecsv = svargs[efix ? efix-1 : svix++];
7047 vecstr = (U8*)SvPVx(vecsv,veclen);
7048 vec_utf = DO_UTF8(vecsv);
7058 i = va_arg(*args, int);
7060 i = (ewix ? ewix <= svmax : svix < svmax) ?
7061 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7063 width = (i < 0) ? -i : i;
7073 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7076 i = va_arg(*args, int);
7078 i = (ewix ? ewix <= svmax : svix < svmax)
7079 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7080 precis = (i < 0) ? 0 : i;
7085 precis = precis * 10 + (*q++ - '0');
7093 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7104 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7105 if (*(q + 1) == 'l') { /* lld, llf */
7128 argsv = (efix ? efix <= svmax : svix < svmax) ?
7129 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7136 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7138 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7140 eptr = (char*)utf8buf;
7141 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7153 eptr = va_arg(*args, char*);
7155 #ifdef MACOS_TRADITIONAL
7156 /* On MacOS, %#s format is used for Pascal strings */
7161 elen = strlen(eptr);
7164 elen = sizeof nullstr - 1;
7168 eptr = SvPVx(argsv, elen);
7169 if (DO_UTF8(argsv)) {
7170 if (has_precis && precis < elen) {
7172 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7175 if (width) { /* fudge width (can't fudge elen) */
7176 width += elen - sv_len_utf8(argsv);
7185 * The "%_" hack might have to be changed someday,
7186 * if ISO or ANSI decide to use '_' for something.
7187 * So we keep it hidden from users' code.
7191 argsv = va_arg(*args, SV*);
7192 eptr = SvPVx(argsv, elen);
7198 if (has_precis && elen > precis)
7207 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7225 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7235 case 'h': iv = (short)va_arg(*args, int); break;
7236 default: iv = va_arg(*args, int); break;
7237 case 'l': iv = va_arg(*args, long); break;
7238 case 'V': iv = va_arg(*args, IV); break;
7240 case 'q': iv = va_arg(*args, Quad_t); break;
7247 case 'h': iv = (short)iv; break;
7249 case 'l': iv = (long)iv; break;
7252 case 'q': iv = (Quad_t)iv; break;
7259 esignbuf[esignlen++] = plus;
7263 esignbuf[esignlen++] = '-';
7305 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7315 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7316 default: uv = va_arg(*args, unsigned); break;
7317 case 'l': uv = va_arg(*args, unsigned long); break;
7318 case 'V': uv = va_arg(*args, UV); break;
7320 case 'q': uv = va_arg(*args, Quad_t); break;
7327 case 'h': uv = (unsigned short)uv; break;
7329 case 'l': uv = (unsigned long)uv; break;
7332 case 'q': uv = (Quad_t)uv; break;
7338 eptr = ebuf + sizeof ebuf;
7344 p = (char*)((c == 'X')
7345 ? "0123456789ABCDEF" : "0123456789abcdef");
7351 esignbuf[esignlen++] = '0';
7352 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7358 *--eptr = '0' + dig;
7360 if (alt && *eptr != '0')
7366 *--eptr = '0' + dig;
7369 esignbuf[esignlen++] = '0';
7370 esignbuf[esignlen++] = 'b';
7373 default: /* it had better be ten or less */
7374 #if defined(PERL_Y2KWARN)
7375 if (ckWARN(WARN_Y2K)) {
7377 char *s = SvPV(sv,n);
7378 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7379 && (n == 2 || !isDIGIT(s[n-3])))
7381 Perl_warner(aTHX_ WARN_Y2K,
7382 "Possible Y2K bug: %%%c %s",
7383 c, "format string following '19'");
7389 *--eptr = '0' + dig;
7390 } while (uv /= base);
7393 elen = (ebuf + sizeof ebuf) - eptr;
7396 zeros = precis - elen;
7397 else if (precis == 0 && elen == 1 && *eptr == '0')
7402 /* FLOATING POINT */
7405 c = 'f'; /* maybe %F isn't supported here */
7411 /* This is evil, but floating point is even more evil */
7414 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7417 if (c != 'e' && c != 'E') {
7419 (void)Perl_frexp(nv, &i);
7420 if (i == PERL_INT_MIN)
7421 Perl_die(aTHX_ "panic: frexp");
7423 need = BIT_DIGITS(i);
7425 need += has_precis ? precis : 6; /* known default */
7429 need += 20; /* fudge factor */
7430 if (PL_efloatsize < need) {
7431 Safefree(PL_efloatbuf);
7432 PL_efloatsize = need + 20; /* more fudge */
7433 New(906, PL_efloatbuf, PL_efloatsize, char);
7434 PL_efloatbuf[0] = '\0';
7437 eptr = ebuf + sizeof ebuf;
7440 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7442 /* Copy the one or more characters in a long double
7443 * format before the 'base' ([efgEFG]) character to
7444 * the format string. */
7445 static char const prifldbl[] = PERL_PRIfldbl;
7446 char const *p = prifldbl + sizeof(prifldbl) - 3;
7447 while (p >= prifldbl) { *--eptr = *p--; }
7452 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7457 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7469 /* No taint. Otherwise we are in the strange situation
7470 * where printf() taints but print($float) doesn't.
7472 (void)sprintf(PL_efloatbuf, eptr, nv);
7474 eptr = PL_efloatbuf;
7475 elen = strlen(PL_efloatbuf);
7482 i = SvCUR(sv) - origlen;
7485 case 'h': *(va_arg(*args, short*)) = i; break;
7486 default: *(va_arg(*args, int*)) = i; break;
7487 case 'l': *(va_arg(*args, long*)) = i; break;
7488 case 'V': *(va_arg(*args, IV*)) = i; break;
7490 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7495 sv_setuv_mg(argsv, (UV)i);
7496 continue; /* not "break" */
7503 if (!args && ckWARN(WARN_PRINTF) &&
7504 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7505 SV *msg = sv_newmortal();
7506 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7507 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7510 Perl_sv_catpvf(aTHX_ msg,
7511 "\"%%%c\"", c & 0xFF);
7513 Perl_sv_catpvf(aTHX_ msg,
7514 "\"%%\\%03"UVof"\"",
7517 sv_catpv(msg, "end of string");
7518 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7521 /* output mangled stuff ... */
7527 /* ... right here, because formatting flags should not apply */
7528 SvGROW(sv, SvCUR(sv) + elen + 1);
7530 Copy(eptr, p, elen, char);
7533 SvCUR(sv) = p - SvPVX(sv);
7534 continue; /* not "break" */
7537 have = esignlen + zeros + elen;
7538 need = (have > width ? have : width);
7541 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7543 if (esignlen && fill == '0') {
7544 for (i = 0; i < esignlen; i++)
7548 memset(p, fill, gap);
7551 if (esignlen && fill != '0') {
7552 for (i = 0; i < esignlen; i++)
7556 for (i = zeros; i; i--)
7560 Copy(eptr, p, elen, char);
7564 memset(p, ' ', gap);
7569 Copy(dotstr, p, dotstrlen, char);
7573 vectorize = FALSE; /* done iterating over vecstr */
7578 SvCUR(sv) = p - SvPVX(sv);
7586 #if defined(USE_ITHREADS)
7588 #if defined(USE_THREADS)
7589 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7592 #ifndef GpREFCNT_inc
7593 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7597 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7598 #define av_dup(s) (AV*)sv_dup((SV*)s)
7599 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7600 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7601 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7602 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7603 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7604 #define io_dup(s) (IO*)sv_dup((SV*)s)
7605 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7606 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7607 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7608 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7609 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7612 Perl_re_dup(pTHX_ REGEXP *r)
7614 /* XXX fix when pmop->op_pmregexp becomes shared */
7615 return ReREFCNT_inc(r);
7619 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7623 return (PerlIO*)NULL;
7625 /* look for it in the table first */
7626 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7630 /* create anew and remember what it is */
7631 ret = PerlIO_fdupopen(aTHX_ fp);
7632 ptr_table_store(PL_ptr_table, fp, ret);
7637 Perl_dirp_dup(pTHX_ DIR *dp)
7646 Perl_gp_dup(pTHX_ GP *gp)
7651 /* look for it in the table first */
7652 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7656 /* create anew and remember what it is */
7657 Newz(0, ret, 1, GP);
7658 ptr_table_store(PL_ptr_table, gp, ret);
7661 ret->gp_refcnt = 0; /* must be before any other dups! */
7662 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7663 ret->gp_io = io_dup_inc(gp->gp_io);
7664 ret->gp_form = cv_dup_inc(gp->gp_form);
7665 ret->gp_av = av_dup_inc(gp->gp_av);
7666 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7667 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7668 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7669 ret->gp_cvgen = gp->gp_cvgen;
7670 ret->gp_flags = gp->gp_flags;
7671 ret->gp_line = gp->gp_line;
7672 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7677 Perl_mg_dup(pTHX_ MAGIC *mg)
7679 MAGIC *mgret = (MAGIC*)NULL;
7682 return (MAGIC*)NULL;
7683 /* look for it in the table first */
7684 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7688 for (; mg; mg = mg->mg_moremagic) {
7690 Newz(0, nmg, 1, MAGIC);
7694 mgprev->mg_moremagic = nmg;
7695 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7696 nmg->mg_private = mg->mg_private;
7697 nmg->mg_type = mg->mg_type;
7698 nmg->mg_flags = mg->mg_flags;
7699 if (mg->mg_type == 'r') {
7700 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7703 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7704 ? sv_dup_inc(mg->mg_obj)
7705 : sv_dup(mg->mg_obj);
7707 nmg->mg_len = mg->mg_len;
7708 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7709 if (mg->mg_ptr && mg->mg_type != 'g') {
7710 if (mg->mg_len >= 0) {
7711 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7712 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7713 AMT *amtp = (AMT*)mg->mg_ptr;
7714 AMT *namtp = (AMT*)nmg->mg_ptr;
7716 for (i = 1; i < NofAMmeth; i++) {
7717 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7721 else if (mg->mg_len == HEf_SVKEY)
7722 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7730 Perl_ptr_table_new(pTHX)
7733 Newz(0, tbl, 1, PTR_TBL_t);
7736 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7741 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7743 PTR_TBL_ENT_t *tblent;
7744 UV hash = PTR2UV(sv);
7746 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7747 for (; tblent; tblent = tblent->next) {
7748 if (tblent->oldval == sv)
7749 return tblent->newval;
7755 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7757 PTR_TBL_ENT_t *tblent, **otblent;
7758 /* XXX this may be pessimal on platforms where pointers aren't good
7759 * hash values e.g. if they grow faster in the most significant
7761 UV hash = PTR2UV(oldv);
7765 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7766 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7767 if (tblent->oldval == oldv) {
7768 tblent->newval = newv;
7773 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7774 tblent->oldval = oldv;
7775 tblent->newval = newv;
7776 tblent->next = *otblent;
7779 if (i && tbl->tbl_items > tbl->tbl_max)
7780 ptr_table_split(tbl);
7784 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7786 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7787 UV oldsize = tbl->tbl_max + 1;
7788 UV newsize = oldsize * 2;
7791 Renew(ary, newsize, PTR_TBL_ENT_t*);
7792 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7793 tbl->tbl_max = --newsize;
7795 for (i=0; i < oldsize; i++, ary++) {
7796 PTR_TBL_ENT_t **curentp, **entp, *ent;
7799 curentp = ary + oldsize;
7800 for (entp = ary, ent = *ary; ent; ent = *entp) {
7801 if ((newsize & PTR2UV(ent->oldval)) != i) {
7803 ent->next = *curentp;
7814 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7816 register PTR_TBL_ENT_t **array;
7817 register PTR_TBL_ENT_t *entry;
7818 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7822 if (!tbl || !tbl->tbl_items) {
7826 array = tbl->tbl_ary;
7833 entry = entry->next;
7837 if (++riter > max) {
7840 entry = array[riter];
7848 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7853 ptr_table_clear(tbl);
7854 Safefree(tbl->tbl_ary);
7863 S_gv_share(pTHX_ SV *sstr)
7866 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7868 if (GvIO(gv) || GvFORM(gv)) {
7869 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
7871 else if (!GvCV(gv)) {
7875 /* CvPADLISTs cannot be shared */
7876 if (!CvXSUB(GvCV(gv))) {
7881 if (!GvSHARED(gv)) {
7883 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
7884 HvNAME(GvSTASH(gv)), GvNAME(gv));
7890 * write attempts will die with
7891 * "Modification of a read-only value attempted"
7897 SvREADONLY_on(GvSV(gv));
7904 SvREADONLY_on(GvAV(gv));
7911 SvREADONLY_on(GvAV(gv));
7914 return sstr; /* he_dup() will SvREFCNT_inc() */
7918 Perl_sv_dup(pTHX_ SV *sstr)
7922 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7924 /* look for it in the table first */
7925 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7929 /* create anew and remember what it is */
7931 ptr_table_store(PL_ptr_table, sstr, dstr);
7934 SvFLAGS(dstr) = SvFLAGS(sstr);
7935 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7936 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7939 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7940 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7941 PL_watch_pvx, SvPVX(sstr));
7944 switch (SvTYPE(sstr)) {
7949 SvANY(dstr) = new_XIV();
7950 SvIVX(dstr) = SvIVX(sstr);
7953 SvANY(dstr) = new_XNV();
7954 SvNVX(dstr) = SvNVX(sstr);
7957 SvANY(dstr) = new_XRV();
7958 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7961 SvANY(dstr) = new_XPV();
7962 SvCUR(dstr) = SvCUR(sstr);
7963 SvLEN(dstr) = SvLEN(sstr);
7965 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7966 else if (SvPVX(sstr) && SvLEN(sstr))
7967 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7969 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7972 SvANY(dstr) = new_XPVIV();
7973 SvCUR(dstr) = SvCUR(sstr);
7974 SvLEN(dstr) = SvLEN(sstr);
7975 SvIVX(dstr) = SvIVX(sstr);
7977 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7978 else if (SvPVX(sstr) && SvLEN(sstr))
7979 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7981 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7984 SvANY(dstr) = new_XPVNV();
7985 SvCUR(dstr) = SvCUR(sstr);
7986 SvLEN(dstr) = SvLEN(sstr);
7987 SvIVX(dstr) = SvIVX(sstr);
7988 SvNVX(dstr) = SvNVX(sstr);
7990 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7991 else if (SvPVX(sstr) && SvLEN(sstr))
7992 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7994 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7997 SvANY(dstr) = new_XPVMG();
7998 SvCUR(dstr) = SvCUR(sstr);
7999 SvLEN(dstr) = SvLEN(sstr);
8000 SvIVX(dstr) = SvIVX(sstr);
8001 SvNVX(dstr) = SvNVX(sstr);
8002 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8003 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8005 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8006 else if (SvPVX(sstr) && SvLEN(sstr))
8007 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8009 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8012 SvANY(dstr) = new_XPVBM();
8013 SvCUR(dstr) = SvCUR(sstr);
8014 SvLEN(dstr) = SvLEN(sstr);
8015 SvIVX(dstr) = SvIVX(sstr);
8016 SvNVX(dstr) = SvNVX(sstr);
8017 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8018 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8020 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8021 else if (SvPVX(sstr) && SvLEN(sstr))
8022 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8024 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8025 BmRARE(dstr) = BmRARE(sstr);
8026 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8027 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8030 SvANY(dstr) = new_XPVLV();
8031 SvCUR(dstr) = SvCUR(sstr);
8032 SvLEN(dstr) = SvLEN(sstr);
8033 SvIVX(dstr) = SvIVX(sstr);
8034 SvNVX(dstr) = SvNVX(sstr);
8035 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8036 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8038 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8039 else if (SvPVX(sstr) && SvLEN(sstr))
8040 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8042 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8043 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8044 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8045 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8046 LvTYPE(dstr) = LvTYPE(sstr);
8049 if (GvSHARED((GV*)sstr)) {
8051 if ((share = gv_share(sstr))) {
8055 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8056 HvNAME(GvSTASH(share)), GvNAME(share));
8061 SvANY(dstr) = new_XPVGV();
8062 SvCUR(dstr) = SvCUR(sstr);
8063 SvLEN(dstr) = SvLEN(sstr);
8064 SvIVX(dstr) = SvIVX(sstr);
8065 SvNVX(dstr) = SvNVX(sstr);
8066 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8067 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8069 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8070 else if (SvPVX(sstr) && SvLEN(sstr))
8071 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8073 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8074 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8075 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8076 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8077 GvFLAGS(dstr) = GvFLAGS(sstr);
8078 GvGP(dstr) = gp_dup(GvGP(sstr));
8079 (void)GpREFCNT_inc(GvGP(dstr));
8082 SvANY(dstr) = new_XPVIO();
8083 SvCUR(dstr) = SvCUR(sstr);
8084 SvLEN(dstr) = SvLEN(sstr);
8085 SvIVX(dstr) = SvIVX(sstr);
8086 SvNVX(dstr) = SvNVX(sstr);
8087 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8088 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8090 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8091 else if (SvPVX(sstr) && SvLEN(sstr))
8092 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8094 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8095 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8096 if (IoOFP(sstr) == IoIFP(sstr))
8097 IoOFP(dstr) = IoIFP(dstr);
8099 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8100 /* PL_rsfp_filters entries have fake IoDIRP() */
8101 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8102 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8104 IoDIRP(dstr) = IoDIRP(sstr);
8105 IoLINES(dstr) = IoLINES(sstr);
8106 IoPAGE(dstr) = IoPAGE(sstr);
8107 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8108 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8109 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8110 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8111 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8112 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8113 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8114 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8115 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8116 IoTYPE(dstr) = IoTYPE(sstr);
8117 IoFLAGS(dstr) = IoFLAGS(sstr);
8120 SvANY(dstr) = new_XPVAV();
8121 SvCUR(dstr) = SvCUR(sstr);
8122 SvLEN(dstr) = SvLEN(sstr);
8123 SvIVX(dstr) = SvIVX(sstr);
8124 SvNVX(dstr) = SvNVX(sstr);
8125 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8126 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8127 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8128 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8129 if (AvARRAY((AV*)sstr)) {
8130 SV **dst_ary, **src_ary;
8131 SSize_t items = AvFILLp((AV*)sstr) + 1;
8133 src_ary = AvARRAY((AV*)sstr);
8134 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8135 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8136 SvPVX(dstr) = (char*)dst_ary;
8137 AvALLOC((AV*)dstr) = dst_ary;
8138 if (AvREAL((AV*)sstr)) {
8140 *dst_ary++ = sv_dup_inc(*src_ary++);
8144 *dst_ary++ = sv_dup(*src_ary++);
8146 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8147 while (items-- > 0) {
8148 *dst_ary++ = &PL_sv_undef;
8152 SvPVX(dstr) = Nullch;
8153 AvALLOC((AV*)dstr) = (SV**)NULL;
8157 SvANY(dstr) = new_XPVHV();
8158 SvCUR(dstr) = SvCUR(sstr);
8159 SvLEN(dstr) = SvLEN(sstr);
8160 SvIVX(dstr) = SvIVX(sstr);
8161 SvNVX(dstr) = SvNVX(sstr);
8162 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8163 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8164 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8165 if (HvARRAY((HV*)sstr)) {
8167 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8168 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8169 Newz(0, dxhv->xhv_array,
8170 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8171 while (i <= sxhv->xhv_max) {
8172 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8173 !!HvSHAREKEYS(sstr));
8176 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8179 SvPVX(dstr) = Nullch;
8180 HvEITER((HV*)dstr) = (HE*)NULL;
8182 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8183 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8186 SvANY(dstr) = new_XPVFM();
8187 FmLINES(dstr) = FmLINES(sstr);
8191 SvANY(dstr) = new_XPVCV();
8193 SvCUR(dstr) = SvCUR(sstr);
8194 SvLEN(dstr) = SvLEN(sstr);
8195 SvIVX(dstr) = SvIVX(sstr);
8196 SvNVX(dstr) = SvNVX(sstr);
8197 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8198 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8199 if (SvPVX(sstr) && SvLEN(sstr))
8200 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8202 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8203 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8204 CvSTART(dstr) = CvSTART(sstr);
8205 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8206 CvXSUB(dstr) = CvXSUB(sstr);
8207 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8208 CvGV(dstr) = gv_dup(CvGV(sstr));
8209 CvDEPTH(dstr) = CvDEPTH(sstr);
8210 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8211 /* XXX padlists are real, but pretend to be not */
8212 AvREAL_on(CvPADLIST(sstr));
8213 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8214 AvREAL_off(CvPADLIST(sstr));
8215 AvREAL_off(CvPADLIST(dstr));
8218 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8219 if (!CvANON(sstr) || CvCLONED(sstr))
8220 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8222 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8223 CvFLAGS(dstr) = CvFLAGS(sstr);
8226 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8230 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8237 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8242 return (PERL_CONTEXT*)NULL;
8244 /* look for it in the table first */
8245 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8249 /* create anew and remember what it is */
8250 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8251 ptr_table_store(PL_ptr_table, cxs, ncxs);
8254 PERL_CONTEXT *cx = &cxs[ix];
8255 PERL_CONTEXT *ncx = &ncxs[ix];
8256 ncx->cx_type = cx->cx_type;
8257 if (CxTYPE(cx) == CXt_SUBST) {
8258 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8261 ncx->blk_oldsp = cx->blk_oldsp;
8262 ncx->blk_oldcop = cx->blk_oldcop;
8263 ncx->blk_oldretsp = cx->blk_oldretsp;
8264 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8265 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8266 ncx->blk_oldpm = cx->blk_oldpm;
8267 ncx->blk_gimme = cx->blk_gimme;
8268 switch (CxTYPE(cx)) {
8270 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8271 ? cv_dup_inc(cx->blk_sub.cv)
8272 : cv_dup(cx->blk_sub.cv));
8273 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8274 ? av_dup_inc(cx->blk_sub.argarray)
8276 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8277 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8278 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8279 ncx->blk_sub.lval = cx->blk_sub.lval;
8282 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8283 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8284 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8285 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8286 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8289 ncx->blk_loop.label = cx->blk_loop.label;
8290 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8291 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8292 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8293 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8294 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8295 ? cx->blk_loop.iterdata
8296 : gv_dup((GV*)cx->blk_loop.iterdata));
8297 ncx->blk_loop.oldcurpad
8298 = (SV**)ptr_table_fetch(PL_ptr_table,
8299 cx->blk_loop.oldcurpad);
8300 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8301 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8302 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8303 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8304 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8307 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8308 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8309 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8310 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8323 Perl_si_dup(pTHX_ PERL_SI *si)
8328 return (PERL_SI*)NULL;
8330 /* look for it in the table first */
8331 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8335 /* create anew and remember what it is */
8336 Newz(56, nsi, 1, PERL_SI);
8337 ptr_table_store(PL_ptr_table, si, nsi);
8339 nsi->si_stack = av_dup_inc(si->si_stack);
8340 nsi->si_cxix = si->si_cxix;
8341 nsi->si_cxmax = si->si_cxmax;
8342 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8343 nsi->si_type = si->si_type;
8344 nsi->si_prev = si_dup(si->si_prev);
8345 nsi->si_next = si_dup(si->si_next);
8346 nsi->si_markoff = si->si_markoff;
8351 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8352 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8353 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8354 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8355 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8356 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8357 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8358 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8359 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8360 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8361 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8362 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8365 #define pv_dup_inc(p) SAVEPV(p)
8366 #define pv_dup(p) SAVEPV(p)
8367 #define svp_dup_inc(p,pp) any_dup(p,pp)
8370 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8377 /* look for it in the table first */
8378 ret = ptr_table_fetch(PL_ptr_table, v);
8382 /* see if it is part of the interpreter structure */
8383 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8384 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8392 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8394 ANY *ss = proto_perl->Tsavestack;
8395 I32 ix = proto_perl->Tsavestack_ix;
8396 I32 max = proto_perl->Tsavestack_max;
8409 void (*dptr) (void*);
8410 void (*dxptr) (pTHXo_ void*);
8413 Newz(54, nss, max, ANY);
8419 case SAVEt_ITEM: /* normal string */
8420 sv = (SV*)POPPTR(ss,ix);
8421 TOPPTR(nss,ix) = sv_dup_inc(sv);
8422 sv = (SV*)POPPTR(ss,ix);
8423 TOPPTR(nss,ix) = sv_dup_inc(sv);
8425 case SAVEt_SV: /* scalar reference */
8426 sv = (SV*)POPPTR(ss,ix);
8427 TOPPTR(nss,ix) = sv_dup_inc(sv);
8428 gv = (GV*)POPPTR(ss,ix);
8429 TOPPTR(nss,ix) = gv_dup_inc(gv);
8431 case SAVEt_GENERIC_PVREF: /* generic char* */
8432 c = (char*)POPPTR(ss,ix);
8433 TOPPTR(nss,ix) = pv_dup(c);
8434 ptr = POPPTR(ss,ix);
8435 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8437 case SAVEt_GENERIC_SVREF: /* generic sv */
8438 case SAVEt_SVREF: /* scalar reference */
8439 sv = (SV*)POPPTR(ss,ix);
8440 TOPPTR(nss,ix) = sv_dup_inc(sv);
8441 ptr = POPPTR(ss,ix);
8442 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8444 case SAVEt_AV: /* array reference */
8445 av = (AV*)POPPTR(ss,ix);
8446 TOPPTR(nss,ix) = av_dup_inc(av);
8447 gv = (GV*)POPPTR(ss,ix);
8448 TOPPTR(nss,ix) = gv_dup(gv);
8450 case SAVEt_HV: /* hash reference */
8451 hv = (HV*)POPPTR(ss,ix);
8452 TOPPTR(nss,ix) = hv_dup_inc(hv);
8453 gv = (GV*)POPPTR(ss,ix);
8454 TOPPTR(nss,ix) = gv_dup(gv);
8456 case SAVEt_INT: /* int reference */
8457 ptr = POPPTR(ss,ix);
8458 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8459 intval = (int)POPINT(ss,ix);
8460 TOPINT(nss,ix) = intval;
8462 case SAVEt_LONG: /* long reference */
8463 ptr = POPPTR(ss,ix);
8464 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8465 longval = (long)POPLONG(ss,ix);
8466 TOPLONG(nss,ix) = longval;
8468 case SAVEt_I32: /* I32 reference */
8469 case SAVEt_I16: /* I16 reference */
8470 case SAVEt_I8: /* I8 reference */
8471 ptr = POPPTR(ss,ix);
8472 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8476 case SAVEt_IV: /* IV reference */
8477 ptr = POPPTR(ss,ix);
8478 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8482 case SAVEt_SPTR: /* SV* reference */
8483 ptr = POPPTR(ss,ix);
8484 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8485 sv = (SV*)POPPTR(ss,ix);
8486 TOPPTR(nss,ix) = sv_dup(sv);
8488 case SAVEt_VPTR: /* random* reference */
8489 ptr = POPPTR(ss,ix);
8490 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8491 ptr = POPPTR(ss,ix);
8492 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8494 case SAVEt_PPTR: /* char* reference */
8495 ptr = POPPTR(ss,ix);
8496 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8497 c = (char*)POPPTR(ss,ix);
8498 TOPPTR(nss,ix) = pv_dup(c);
8500 case SAVEt_HPTR: /* HV* reference */
8501 ptr = POPPTR(ss,ix);
8502 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8503 hv = (HV*)POPPTR(ss,ix);
8504 TOPPTR(nss,ix) = hv_dup(hv);
8506 case SAVEt_APTR: /* AV* reference */
8507 ptr = POPPTR(ss,ix);
8508 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8509 av = (AV*)POPPTR(ss,ix);
8510 TOPPTR(nss,ix) = av_dup(av);
8513 gv = (GV*)POPPTR(ss,ix);
8514 TOPPTR(nss,ix) = gv_dup(gv);
8516 case SAVEt_GP: /* scalar reference */
8517 gp = (GP*)POPPTR(ss,ix);
8518 TOPPTR(nss,ix) = gp = gp_dup(gp);
8519 (void)GpREFCNT_inc(gp);
8520 gv = (GV*)POPPTR(ss,ix);
8521 TOPPTR(nss,ix) = gv_dup_inc(c);
8522 c = (char*)POPPTR(ss,ix);
8523 TOPPTR(nss,ix) = pv_dup(c);
8530 sv = (SV*)POPPTR(ss,ix);
8531 TOPPTR(nss,ix) = sv_dup_inc(sv);
8534 ptr = POPPTR(ss,ix);
8535 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8536 /* these are assumed to be refcounted properly */
8537 switch (((OP*)ptr)->op_type) {
8544 TOPPTR(nss,ix) = ptr;
8549 TOPPTR(nss,ix) = Nullop;
8554 TOPPTR(nss,ix) = Nullop;
8557 c = (char*)POPPTR(ss,ix);
8558 TOPPTR(nss,ix) = pv_dup_inc(c);
8561 longval = POPLONG(ss,ix);
8562 TOPLONG(nss,ix) = longval;
8565 hv = (HV*)POPPTR(ss,ix);
8566 TOPPTR(nss,ix) = hv_dup_inc(hv);
8567 c = (char*)POPPTR(ss,ix);
8568 TOPPTR(nss,ix) = pv_dup_inc(c);
8572 case SAVEt_DESTRUCTOR:
8573 ptr = POPPTR(ss,ix);
8574 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8575 dptr = POPDPTR(ss,ix);
8576 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8578 case SAVEt_DESTRUCTOR_X:
8579 ptr = POPPTR(ss,ix);
8580 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8581 dxptr = POPDXPTR(ss,ix);
8582 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8584 case SAVEt_REGCONTEXT:
8590 case SAVEt_STACK_POS: /* Position on Perl stack */
8594 case SAVEt_AELEM: /* array element */
8595 sv = (SV*)POPPTR(ss,ix);
8596 TOPPTR(nss,ix) = sv_dup_inc(sv);
8599 av = (AV*)POPPTR(ss,ix);
8600 TOPPTR(nss,ix) = av_dup_inc(av);
8602 case SAVEt_HELEM: /* hash element */
8603 sv = (SV*)POPPTR(ss,ix);
8604 TOPPTR(nss,ix) = sv_dup_inc(sv);
8605 sv = (SV*)POPPTR(ss,ix);
8606 TOPPTR(nss,ix) = sv_dup_inc(sv);
8607 hv = (HV*)POPPTR(ss,ix);
8608 TOPPTR(nss,ix) = hv_dup_inc(hv);
8611 ptr = POPPTR(ss,ix);
8612 TOPPTR(nss,ix) = ptr;
8619 av = (AV*)POPPTR(ss,ix);
8620 TOPPTR(nss,ix) = av_dup(av);
8623 longval = (long)POPLONG(ss,ix);
8624 TOPLONG(nss,ix) = longval;
8625 ptr = POPPTR(ss,ix);
8626 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8627 sv = (SV*)POPPTR(ss,ix);
8628 TOPPTR(nss,ix) = sv_dup(sv);
8631 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8643 perl_clone(PerlInterpreter *proto_perl, UV flags)
8646 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8649 #ifdef PERL_IMPLICIT_SYS
8650 return perl_clone_using(proto_perl, flags,
8652 proto_perl->IMemShared,
8653 proto_perl->IMemParse,
8663 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8664 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8665 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8666 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8667 struct IPerlDir* ipD, struct IPerlSock* ipS,
8668 struct IPerlProc* ipP)
8670 /* XXX many of the string copies here can be optimized if they're
8671 * constants; they need to be allocated as common memory and just
8672 * their pointers copied. */
8676 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8678 PERL_SET_THX(pPerl);
8679 # else /* !PERL_OBJECT */
8680 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8681 PERL_SET_THX(my_perl);
8684 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8690 # else /* !DEBUGGING */
8691 Zero(my_perl, 1, PerlInterpreter);
8692 # endif /* DEBUGGING */
8696 PL_MemShared = ipMS;
8704 # endif /* PERL_OBJECT */
8705 #else /* !PERL_IMPLICIT_SYS */
8707 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8708 PERL_SET_THX(my_perl);
8711 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8717 # else /* !DEBUGGING */
8718 Zero(my_perl, 1, PerlInterpreter);
8719 # endif /* DEBUGGING */
8720 #endif /* PERL_IMPLICIT_SYS */
8723 PL_xiv_arenaroot = NULL;
8725 PL_xnv_arenaroot = NULL;
8727 PL_xrv_arenaroot = NULL;
8729 PL_xpv_arenaroot = NULL;
8731 PL_xpviv_arenaroot = NULL;
8732 PL_xpviv_root = NULL;
8733 PL_xpvnv_arenaroot = NULL;
8734 PL_xpvnv_root = NULL;
8735 PL_xpvcv_arenaroot = NULL;
8736 PL_xpvcv_root = NULL;
8737 PL_xpvav_arenaroot = NULL;
8738 PL_xpvav_root = NULL;
8739 PL_xpvhv_arenaroot = NULL;
8740 PL_xpvhv_root = NULL;
8741 PL_xpvmg_arenaroot = NULL;
8742 PL_xpvmg_root = NULL;
8743 PL_xpvlv_arenaroot = NULL;
8744 PL_xpvlv_root = NULL;
8745 PL_xpvbm_arenaroot = NULL;
8746 PL_xpvbm_root = NULL;
8747 PL_he_arenaroot = NULL;
8749 PL_nice_chunk = NULL;
8750 PL_nice_chunk_size = 0;
8753 PL_sv_root = Nullsv;
8754 PL_sv_arenaroot = Nullsv;
8756 PL_debug = proto_perl->Idebug;
8758 /* create SV map for pointer relocation */
8759 PL_ptr_table = ptr_table_new();
8761 /* initialize these special pointers as early as possible */
8762 SvANY(&PL_sv_undef) = NULL;
8763 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8764 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8765 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8768 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8770 SvANY(&PL_sv_no) = new_XPVNV();
8772 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8773 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8774 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8775 SvCUR(&PL_sv_no) = 0;
8776 SvLEN(&PL_sv_no) = 1;
8777 SvNVX(&PL_sv_no) = 0;
8778 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8781 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8783 SvANY(&PL_sv_yes) = new_XPVNV();
8785 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8786 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8787 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8788 SvCUR(&PL_sv_yes) = 1;
8789 SvLEN(&PL_sv_yes) = 2;
8790 SvNVX(&PL_sv_yes) = 1;
8791 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8793 /* create shared string table */
8794 PL_strtab = newHV();
8795 HvSHAREKEYS_off(PL_strtab);
8796 hv_ksplit(PL_strtab, 512);
8797 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8799 PL_compiling = proto_perl->Icompiling;
8800 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8801 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8802 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8803 if (!specialWARN(PL_compiling.cop_warnings))
8804 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8805 if (!specialCopIO(PL_compiling.cop_io))
8806 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8807 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8809 /* pseudo environmental stuff */
8810 PL_origargc = proto_perl->Iorigargc;
8812 New(0, PL_origargv, i+1, char*);
8813 PL_origargv[i] = '\0';
8815 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8817 PL_envgv = gv_dup(proto_perl->Ienvgv);
8818 PL_incgv = gv_dup(proto_perl->Iincgv);
8819 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8820 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8821 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8822 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8825 PL_minus_c = proto_perl->Iminus_c;
8826 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8827 PL_localpatches = proto_perl->Ilocalpatches;
8828 PL_splitstr = proto_perl->Isplitstr;
8829 PL_preprocess = proto_perl->Ipreprocess;
8830 PL_minus_n = proto_perl->Iminus_n;
8831 PL_minus_p = proto_perl->Iminus_p;
8832 PL_minus_l = proto_perl->Iminus_l;
8833 PL_minus_a = proto_perl->Iminus_a;
8834 PL_minus_F = proto_perl->Iminus_F;
8835 PL_doswitches = proto_perl->Idoswitches;
8836 PL_dowarn = proto_perl->Idowarn;
8837 PL_doextract = proto_perl->Idoextract;
8838 PL_sawampersand = proto_perl->Isawampersand;
8839 PL_unsafe = proto_perl->Iunsafe;
8840 PL_inplace = SAVEPV(proto_perl->Iinplace);
8841 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8842 PL_perldb = proto_perl->Iperldb;
8843 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8845 /* magical thingies */
8846 /* XXX time(&PL_basetime) when asked for? */
8847 PL_basetime = proto_perl->Ibasetime;
8848 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8850 PL_maxsysfd = proto_perl->Imaxsysfd;
8851 PL_multiline = proto_perl->Imultiline;
8852 PL_statusvalue = proto_perl->Istatusvalue;
8854 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8857 /* shortcuts to various I/O objects */
8858 PL_stdingv = gv_dup(proto_perl->Istdingv);
8859 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8860 PL_defgv = gv_dup(proto_perl->Idefgv);
8861 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8862 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8863 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
8865 /* shortcuts to regexp stuff */
8866 PL_replgv = gv_dup(proto_perl->Ireplgv);
8868 /* shortcuts to misc objects */
8869 PL_errgv = gv_dup(proto_perl->Ierrgv);
8871 /* shortcuts to debugging objects */
8872 PL_DBgv = gv_dup(proto_perl->IDBgv);
8873 PL_DBline = gv_dup(proto_perl->IDBline);
8874 PL_DBsub = gv_dup(proto_perl->IDBsub);
8875 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8876 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8877 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8878 PL_lineary = av_dup(proto_perl->Ilineary);
8879 PL_dbargs = av_dup(proto_perl->Idbargs);
8882 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8883 PL_curstash = hv_dup(proto_perl->Tcurstash);
8884 PL_debstash = hv_dup(proto_perl->Idebstash);
8885 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8886 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8888 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8889 PL_endav = av_dup_inc(proto_perl->Iendav);
8890 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8891 PL_initav = av_dup_inc(proto_perl->Iinitav);
8893 PL_sub_generation = proto_perl->Isub_generation;
8895 /* funky return mechanisms */
8896 PL_forkprocess = proto_perl->Iforkprocess;
8898 /* subprocess state */
8899 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8901 /* internal state */
8902 PL_tainting = proto_perl->Itainting;
8903 PL_maxo = proto_perl->Imaxo;
8904 if (proto_perl->Iop_mask)
8905 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8907 PL_op_mask = Nullch;
8909 /* current interpreter roots */
8910 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8911 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8912 PL_main_start = proto_perl->Imain_start;
8913 PL_eval_root = proto_perl->Ieval_root;
8914 PL_eval_start = proto_perl->Ieval_start;
8916 /* runtime control stuff */
8917 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8918 PL_copline = proto_perl->Icopline;
8920 PL_filemode = proto_perl->Ifilemode;
8921 PL_lastfd = proto_perl->Ilastfd;
8922 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8925 PL_gensym = proto_perl->Igensym;
8926 PL_preambled = proto_perl->Ipreambled;
8927 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8928 PL_laststatval = proto_perl->Ilaststatval;
8929 PL_laststype = proto_perl->Ilaststype;
8930 PL_mess_sv = Nullsv;
8932 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8933 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8935 /* interpreter atexit processing */
8936 PL_exitlistlen = proto_perl->Iexitlistlen;
8937 if (PL_exitlistlen) {
8938 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8939 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8942 PL_exitlist = (PerlExitListEntry*)NULL;
8943 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8945 PL_profiledata = NULL;
8946 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8947 /* PL_rsfp_filters entries have fake IoDIRP() */
8948 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8950 PL_compcv = cv_dup(proto_perl->Icompcv);
8951 PL_comppad = av_dup(proto_perl->Icomppad);
8952 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8953 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8954 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8955 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8956 proto_perl->Tcurpad);
8958 #ifdef HAVE_INTERP_INTERN
8959 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8962 /* more statics moved here */
8963 PL_generation = proto_perl->Igeneration;
8964 PL_DBcv = cv_dup(proto_perl->IDBcv);
8966 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8967 PL_in_clean_all = proto_perl->Iin_clean_all;
8969 PL_uid = proto_perl->Iuid;
8970 PL_euid = proto_perl->Ieuid;
8971 PL_gid = proto_perl->Igid;
8972 PL_egid = proto_perl->Iegid;
8973 PL_nomemok = proto_perl->Inomemok;
8974 PL_an = proto_perl->Ian;
8975 PL_cop_seqmax = proto_perl->Icop_seqmax;
8976 PL_op_seqmax = proto_perl->Iop_seqmax;
8977 PL_evalseq = proto_perl->Ievalseq;
8978 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8979 PL_origalen = proto_perl->Iorigalen;
8980 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8981 PL_osname = SAVEPV(proto_perl->Iosname);
8982 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8983 PL_sighandlerp = proto_perl->Isighandlerp;
8986 PL_runops = proto_perl->Irunops;
8988 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8991 PL_cshlen = proto_perl->Icshlen;
8992 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
8995 PL_lex_state = proto_perl->Ilex_state;
8996 PL_lex_defer = proto_perl->Ilex_defer;
8997 PL_lex_expect = proto_perl->Ilex_expect;
8998 PL_lex_formbrack = proto_perl->Ilex_formbrack;
8999 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9000 PL_lex_starts = proto_perl->Ilex_starts;
9001 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
9002 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
9003 PL_lex_op = proto_perl->Ilex_op;
9004 PL_lex_inpat = proto_perl->Ilex_inpat;
9005 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9006 PL_lex_brackets = proto_perl->Ilex_brackets;
9007 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9008 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9009 PL_lex_casemods = proto_perl->Ilex_casemods;
9010 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9011 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9013 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9014 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9015 PL_nexttoke = proto_perl->Inexttoke;
9017 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9018 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9019 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9020 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9021 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9022 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9023 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9024 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9025 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9026 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9027 PL_pending_ident = proto_perl->Ipending_ident;
9028 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9030 PL_expect = proto_perl->Iexpect;
9032 PL_multi_start = proto_perl->Imulti_start;
9033 PL_multi_end = proto_perl->Imulti_end;
9034 PL_multi_open = proto_perl->Imulti_open;
9035 PL_multi_close = proto_perl->Imulti_close;
9037 PL_error_count = proto_perl->Ierror_count;
9038 PL_subline = proto_perl->Isubline;
9039 PL_subname = sv_dup_inc(proto_perl->Isubname);
9041 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9042 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9043 PL_padix = proto_perl->Ipadix;
9044 PL_padix_floor = proto_perl->Ipadix_floor;
9045 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9047 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9048 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9049 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9050 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9051 PL_last_lop_op = proto_perl->Ilast_lop_op;
9052 PL_in_my = proto_perl->Iin_my;
9053 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9055 PL_cryptseen = proto_perl->Icryptseen;
9058 PL_hints = proto_perl->Ihints;
9060 PL_amagic_generation = proto_perl->Iamagic_generation;
9062 #ifdef USE_LOCALE_COLLATE
9063 PL_collation_ix = proto_perl->Icollation_ix;
9064 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9065 PL_collation_standard = proto_perl->Icollation_standard;
9066 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9067 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9068 #endif /* USE_LOCALE_COLLATE */
9070 #ifdef USE_LOCALE_NUMERIC
9071 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9072 PL_numeric_standard = proto_perl->Inumeric_standard;
9073 PL_numeric_local = proto_perl->Inumeric_local;
9074 PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix);
9075 #endif /* !USE_LOCALE_NUMERIC */
9077 /* utf8 character classes */
9078 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9079 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9080 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9081 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9082 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9083 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9084 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9085 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9086 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9087 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9088 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9089 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9090 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9091 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9092 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9093 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9094 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9097 PL_last_swash_hv = Nullhv; /* reinits on demand */
9098 PL_last_swash_klen = 0;
9099 PL_last_swash_key[0]= '\0';
9100 PL_last_swash_tmps = (U8*)NULL;
9101 PL_last_swash_slen = 0;
9103 /* perly.c globals */
9104 PL_yydebug = proto_perl->Iyydebug;
9105 PL_yynerrs = proto_perl->Iyynerrs;
9106 PL_yyerrflag = proto_perl->Iyyerrflag;
9107 PL_yychar = proto_perl->Iyychar;
9108 PL_yyval = proto_perl->Iyyval;
9109 PL_yylval = proto_perl->Iyylval;
9111 PL_glob_index = proto_perl->Iglob_index;
9112 PL_srand_called = proto_perl->Isrand_called;
9113 PL_uudmap['M'] = 0; /* reinits on demand */
9114 PL_bitcount = Nullch; /* reinits on demand */
9116 if (proto_perl->Ipsig_pend) {
9117 Newz(0, PL_psig_pend, SIG_SIZE, int);
9120 PL_psig_pend = (int*)NULL;
9123 if (proto_perl->Ipsig_ptr) {
9124 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9125 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9126 for (i = 1; i < SIG_SIZE; i++) {
9127 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9128 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9132 PL_psig_ptr = (SV**)NULL;
9133 PL_psig_name = (SV**)NULL;
9136 /* thrdvar.h stuff */
9138 if (flags & CLONEf_COPY_STACKS) {
9139 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9140 PL_tmps_ix = proto_perl->Ttmps_ix;
9141 PL_tmps_max = proto_perl->Ttmps_max;
9142 PL_tmps_floor = proto_perl->Ttmps_floor;
9143 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9145 while (i <= PL_tmps_ix) {
9146 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9150 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9151 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9152 Newz(54, PL_markstack, i, I32);
9153 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9154 - proto_perl->Tmarkstack);
9155 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9156 - proto_perl->Tmarkstack);
9157 Copy(proto_perl->Tmarkstack, PL_markstack,
9158 PL_markstack_ptr - PL_markstack + 1, I32);
9160 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9161 * NOTE: unlike the others! */
9162 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9163 PL_scopestack_max = proto_perl->Tscopestack_max;
9164 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9165 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9167 /* next push_return() sets PL_retstack[PL_retstack_ix]
9168 * NOTE: unlike the others! */
9169 PL_retstack_ix = proto_perl->Tretstack_ix;
9170 PL_retstack_max = proto_perl->Tretstack_max;
9171 Newz(54, PL_retstack, PL_retstack_max, OP*);
9172 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9174 /* NOTE: si_dup() looks at PL_markstack */
9175 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9177 /* PL_curstack = PL_curstackinfo->si_stack; */
9178 PL_curstack = av_dup(proto_perl->Tcurstack);
9179 PL_mainstack = av_dup(proto_perl->Tmainstack);
9181 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9182 PL_stack_base = AvARRAY(PL_curstack);
9183 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9184 - proto_perl->Tstack_base);
9185 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9187 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9188 * NOTE: unlike the others! */
9189 PL_savestack_ix = proto_perl->Tsavestack_ix;
9190 PL_savestack_max = proto_perl->Tsavestack_max;
9191 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9192 PL_savestack = ss_dup(proto_perl);
9196 ENTER; /* perl_destruct() wants to LEAVE; */
9199 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9200 PL_top_env = &PL_start_env;
9202 PL_op = proto_perl->Top;
9205 PL_Xpv = (XPV*)NULL;
9206 PL_na = proto_perl->Tna;
9208 PL_statbuf = proto_perl->Tstatbuf;
9209 PL_statcache = proto_perl->Tstatcache;
9210 PL_statgv = gv_dup(proto_perl->Tstatgv);
9211 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9213 PL_timesbuf = proto_perl->Ttimesbuf;
9216 PL_tainted = proto_perl->Ttainted;
9217 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9218 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9219 PL_rs = sv_dup_inc(proto_perl->Trs);
9220 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9221 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9222 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9223 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9224 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9225 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9226 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9228 PL_restartop = proto_perl->Trestartop;
9229 PL_in_eval = proto_perl->Tin_eval;
9230 PL_delaymagic = proto_perl->Tdelaymagic;
9231 PL_dirty = proto_perl->Tdirty;
9232 PL_localizing = proto_perl->Tlocalizing;
9234 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9235 PL_protect = proto_perl->Tprotect;
9237 PL_errors = sv_dup_inc(proto_perl->Terrors);
9238 PL_av_fetch_sv = Nullsv;
9239 PL_hv_fetch_sv = Nullsv;
9240 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9241 PL_modcount = proto_perl->Tmodcount;
9242 PL_lastgotoprobe = Nullop;
9243 PL_dumpindent = proto_perl->Tdumpindent;
9245 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9246 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9247 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9248 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9249 PL_sortcxix = proto_perl->Tsortcxix;
9250 PL_efloatbuf = Nullch; /* reinits on demand */
9251 PL_efloatsize = 0; /* reinits on demand */
9255 PL_screamfirst = NULL;
9256 PL_screamnext = NULL;
9257 PL_maxscream = -1; /* reinits on demand */
9258 PL_lastscream = Nullsv;
9260 PL_watchaddr = NULL;
9261 PL_watchok = Nullch;
9263 PL_regdummy = proto_perl->Tregdummy;
9264 PL_regcomp_parse = Nullch;
9265 PL_regxend = Nullch;
9266 PL_regcode = (regnode*)NULL;
9269 PL_regprecomp = Nullch;
9274 PL_seen_zerolen = 0;
9276 PL_regcomp_rx = (regexp*)NULL;
9278 PL_colorset = 0; /* reinits PL_colors[] */
9279 /*PL_colors[6] = {0,0,0,0,0,0};*/
9280 PL_reg_whilem_seen = 0;
9281 PL_reginput = Nullch;
9284 PL_regstartp = (I32*)NULL;
9285 PL_regendp = (I32*)NULL;
9286 PL_reglastparen = (U32*)NULL;
9287 PL_regtill = Nullch;
9289 PL_reg_start_tmp = (char**)NULL;
9290 PL_reg_start_tmpl = 0;
9291 PL_regdata = (struct reg_data*)NULL;
9294 PL_reg_eval_set = 0;
9296 PL_regprogram = (regnode*)NULL;
9298 PL_regcc = (CURCUR*)NULL;
9299 PL_reg_call_cc = (struct re_cc_state*)NULL;
9300 PL_reg_re = (regexp*)NULL;
9301 PL_reg_ganch = Nullch;
9303 PL_reg_magic = (MAGIC*)NULL;
9305 PL_reg_oldcurpm = (PMOP*)NULL;
9306 PL_reg_curpm = (PMOP*)NULL;
9307 PL_reg_oldsaved = Nullch;
9308 PL_reg_oldsavedlen = 0;
9310 PL_reg_leftiter = 0;
9311 PL_reg_poscache = Nullch;
9312 PL_reg_poscache_size= 0;
9314 /* RE engine - function pointers */
9315 PL_regcompp = proto_perl->Tregcompp;
9316 PL_regexecp = proto_perl->Tregexecp;
9317 PL_regint_start = proto_perl->Tregint_start;
9318 PL_regint_string = proto_perl->Tregint_string;
9319 PL_regfree = proto_perl->Tregfree;
9321 PL_reginterp_cnt = 0;
9322 PL_reg_starttry = 0;
9324 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9325 ptr_table_free(PL_ptr_table);
9326 PL_ptr_table = NULL;
9330 return (PerlInterpreter*)pPerl;
9336 #else /* !USE_ITHREADS */
9342 #endif /* USE_ITHREADS */
9345 do_report_used(pTHXo_ SV *sv)
9347 if (SvTYPE(sv) != SVTYPEMASK) {
9348 PerlIO_printf(Perl_debug_log, "****\n");
9354 do_clean_objs(pTHXo_ SV *sv)
9358 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9359 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9360 if (SvWEAKREF(sv)) {
9371 /* XXX Might want to check arrays, etc. */
9374 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9376 do_clean_named_objs(pTHXo_ SV *sv)
9378 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9379 if ( SvOBJECT(GvSV(sv)) ||
9380 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9381 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9382 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9383 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9385 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9393 do_clean_all(pTHXo_ SV *sv)
9395 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9396 SvFLAGS(sv) |= SVf_BREAK;