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)
2971 (void) sv_2pv(sv,&len);
2979 if (SvREADONLY(sv) && SvFAKE(sv)) {
2980 sv_force_normal(sv);
2983 /* This function could be much more efficient if we had a FLAG in SVs
2984 * to signal if there are any hibit chars in the PV.
2985 * Given that there isn't make loop fast as possible
2987 s = (U8 *) SvPVX(sv);
2988 e = (U8 *) SvEND(sv);
2992 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
2998 len = SvCUR(sv) + 1; /* Plus the \0 */
2999 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3000 SvCUR(sv) = len - 1;
3002 Safefree(s); /* No longer using what was there before. */
3003 SvLEN(sv) = len; /* No longer know the real size. */
3005 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3011 =for apidoc sv_utf8_downgrade
3013 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3014 This may not be possible if the PV contains non-byte encoding characters;
3015 if this is the case, either returns false or, if C<fail_ok> is not
3022 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3024 if (SvPOK(sv) && SvUTF8(sv)) {
3029 if (SvREADONLY(sv) && SvFAKE(sv))
3030 sv_force_normal(sv);
3031 s = (U8 *) SvPV(sv, len);
3032 if (!utf8_to_bytes(s, &len)) {
3035 #ifdef USE_BYTES_DOWNGRADES
3038 U8 *e = (U8 *) SvEND(sv);
3041 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3042 if (first && ch > 255) {
3044 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3045 PL_op_desc[PL_op->op_type]);
3047 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3054 len = (d - (U8 *) SvPVX(sv));
3059 Perl_croak(aTHX_ "Wide character in %s",
3060 PL_op_desc[PL_op->op_type]);
3062 Perl_croak(aTHX_ "Wide character");
3073 =for apidoc sv_utf8_encode
3075 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3076 flag so that it looks like octets again. Used as a building block
3077 for encode_utf8 in Encode.xs
3083 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3085 (void) sv_utf8_upgrade(sv);
3090 =for apidoc sv_utf8_decode
3092 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3093 turn of SvUTF8 if needed so that we see characters. Used as a building block
3094 for decode_utf8 in Encode.xs
3102 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3108 /* The octets may have got themselves encoded - get them back as bytes */
3109 if (!sv_utf8_downgrade(sv, TRUE))
3112 /* it is actually just a matter of turning the utf8 flag on, but
3113 * we want to make sure everything inside is valid utf8 first.
3115 c = (U8 *) SvPVX(sv);
3116 if (!is_utf8_string(c, SvCUR(sv)+1))
3118 e = (U8 *) SvEND(sv);
3121 if (!UTF8_IS_INVARIANT(ch)) {
3131 /* Note: sv_setsv() should not be called with a source string that needs
3132 * to be reused, since it may destroy the source string if it is marked
3137 =for apidoc sv_setsv
3139 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3140 The source SV may be destroyed if it is mortal. Does not handle 'set'
3141 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3148 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3150 register U32 sflags;
3156 SV_CHECK_THINKFIRST(dstr);
3158 sstr = &PL_sv_undef;
3159 stype = SvTYPE(sstr);
3160 dtype = SvTYPE(dstr);
3164 /* There's a lot of redundancy below but we're going for speed here */
3169 if (dtype != SVt_PVGV) {
3170 (void)SvOK_off(dstr);
3178 sv_upgrade(dstr, SVt_IV);
3181 sv_upgrade(dstr, SVt_PVNV);
3185 sv_upgrade(dstr, SVt_PVIV);
3188 (void)SvIOK_only(dstr);
3189 SvIVX(dstr) = SvIVX(sstr);
3192 if (SvTAINTED(sstr))
3203 sv_upgrade(dstr, SVt_NV);
3208 sv_upgrade(dstr, SVt_PVNV);
3211 SvNVX(dstr) = SvNVX(sstr);
3212 (void)SvNOK_only(dstr);
3213 if (SvTAINTED(sstr))
3221 sv_upgrade(dstr, SVt_RV);
3222 else if (dtype == SVt_PVGV &&
3223 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3226 if (GvIMPORTED(dstr) != GVf_IMPORTED
3227 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3229 GvIMPORTED_on(dstr);
3240 sv_upgrade(dstr, SVt_PV);
3243 if (dtype < SVt_PVIV)
3244 sv_upgrade(dstr, SVt_PVIV);
3247 if (dtype < SVt_PVNV)
3248 sv_upgrade(dstr, SVt_PVNV);
3255 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3256 PL_op_name[PL_op->op_type]);
3258 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3262 if (dtype <= SVt_PVGV) {
3264 if (dtype != SVt_PVGV) {
3265 char *name = GvNAME(sstr);
3266 STRLEN len = GvNAMELEN(sstr);
3267 sv_upgrade(dstr, SVt_PVGV);
3268 sv_magic(dstr, dstr, '*', Nullch, 0);
3269 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3270 GvNAME(dstr) = savepvn(name, len);
3271 GvNAMELEN(dstr) = len;
3272 SvFAKE_on(dstr); /* can coerce to non-glob */
3274 /* ahem, death to those who redefine active sort subs */
3275 else if (PL_curstackinfo->si_type == PERLSI_SORT
3276 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3277 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3280 #ifdef GV_SHARED_CHECK
3281 if (GvSHARED((GV*)dstr)) {
3282 Perl_croak(aTHX_ PL_no_modify);
3286 (void)SvOK_off(dstr);
3287 GvINTRO_off(dstr); /* one-shot flag */
3289 GvGP(dstr) = gp_ref(GvGP(sstr));
3290 if (SvTAINTED(sstr))
3292 if (GvIMPORTED(dstr) != GVf_IMPORTED
3293 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3295 GvIMPORTED_on(dstr);
3303 if (SvGMAGICAL(sstr)) {
3305 if (SvTYPE(sstr) != stype) {
3306 stype = SvTYPE(sstr);
3307 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3311 if (stype == SVt_PVLV)
3312 (void)SvUPGRADE(dstr, SVt_PVNV);
3314 (void)SvUPGRADE(dstr, stype);
3317 sflags = SvFLAGS(sstr);
3319 if (sflags & SVf_ROK) {
3320 if (dtype >= SVt_PV) {
3321 if (dtype == SVt_PVGV) {
3322 SV *sref = SvREFCNT_inc(SvRV(sstr));
3324 int intro = GvINTRO(dstr);
3326 #ifdef GV_SHARED_CHECK
3327 if (GvSHARED((GV*)dstr)) {
3328 Perl_croak(aTHX_ PL_no_modify);
3335 GvINTRO_off(dstr); /* one-shot flag */
3336 Newz(602,gp, 1, GP);
3337 GvGP(dstr) = gp_ref(gp);
3338 GvSV(dstr) = NEWSV(72,0);
3339 GvLINE(dstr) = CopLINE(PL_curcop);
3340 GvEGV(dstr) = (GV*)dstr;
3343 switch (SvTYPE(sref)) {
3346 SAVESPTR(GvAV(dstr));
3348 dref = (SV*)GvAV(dstr);
3349 GvAV(dstr) = (AV*)sref;
3350 if (!GvIMPORTED_AV(dstr)
3351 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3353 GvIMPORTED_AV_on(dstr);
3358 SAVESPTR(GvHV(dstr));
3360 dref = (SV*)GvHV(dstr);
3361 GvHV(dstr) = (HV*)sref;
3362 if (!GvIMPORTED_HV(dstr)
3363 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3365 GvIMPORTED_HV_on(dstr);
3370 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3371 SvREFCNT_dec(GvCV(dstr));
3372 GvCV(dstr) = Nullcv;
3373 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3374 PL_sub_generation++;
3376 SAVESPTR(GvCV(dstr));
3379 dref = (SV*)GvCV(dstr);
3380 if (GvCV(dstr) != (CV*)sref) {
3381 CV* cv = GvCV(dstr);
3383 if (!GvCVGEN((GV*)dstr) &&
3384 (CvROOT(cv) || CvXSUB(cv)))
3386 /* ahem, death to those who redefine
3387 * active sort subs */
3388 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3389 PL_sortcop == CvSTART(cv))
3391 "Can't redefine active sort subroutine %s",
3392 GvENAME((GV*)dstr));
3393 /* Redefining a sub - warning is mandatory if
3394 it was a const and its value changed. */
3395 if (ckWARN(WARN_REDEFINE)
3397 && (!CvCONST((CV*)sref)
3398 || sv_cmp(cv_const_sv(cv),
3399 cv_const_sv((CV*)sref)))))
3401 Perl_warner(aTHX_ WARN_REDEFINE,
3403 ? "Constant subroutine %s redefined"
3404 : "Subroutine %s redefined",
3405 GvENAME((GV*)dstr));
3408 cv_ckproto(cv, (GV*)dstr,
3409 SvPOK(sref) ? SvPVX(sref) : Nullch);
3411 GvCV(dstr) = (CV*)sref;
3412 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3413 GvASSUMECV_on(dstr);
3414 PL_sub_generation++;
3416 if (!GvIMPORTED_CV(dstr)
3417 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3419 GvIMPORTED_CV_on(dstr);
3424 SAVESPTR(GvIOp(dstr));
3426 dref = (SV*)GvIOp(dstr);
3427 GvIOp(dstr) = (IO*)sref;
3431 SAVESPTR(GvFORM(dstr));
3433 dref = (SV*)GvFORM(dstr);
3434 GvFORM(dstr) = (CV*)sref;
3438 SAVESPTR(GvSV(dstr));
3440 dref = (SV*)GvSV(dstr);
3442 if (!GvIMPORTED_SV(dstr)
3443 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3445 GvIMPORTED_SV_on(dstr);
3453 if (SvTAINTED(sstr))
3458 (void)SvOOK_off(dstr); /* backoff */
3460 Safefree(SvPVX(dstr));
3461 SvLEN(dstr)=SvCUR(dstr)=0;
3464 (void)SvOK_off(dstr);
3465 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3467 if (sflags & SVp_NOK) {
3469 /* Only set the public OK flag if the source has public OK. */
3470 if (sflags & SVf_NOK)
3471 SvFLAGS(dstr) |= SVf_NOK;
3472 SvNVX(dstr) = SvNVX(sstr);
3474 if (sflags & SVp_IOK) {
3475 (void)SvIOKp_on(dstr);
3476 if (sflags & SVf_IOK)
3477 SvFLAGS(dstr) |= SVf_IOK;
3478 if (sflags & SVf_IVisUV)
3480 SvIVX(dstr) = SvIVX(sstr);
3482 if (SvAMAGIC(sstr)) {
3486 else if (sflags & SVp_POK) {
3489 * Check to see if we can just swipe the string. If so, it's a
3490 * possible small lose on short strings, but a big win on long ones.
3491 * It might even be a win on short strings if SvPVX(dstr)
3492 * has to be allocated and SvPVX(sstr) has to be freed.
3495 if (SvTEMP(sstr) && /* slated for free anyway? */
3496 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3497 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3498 SvLEN(sstr) && /* and really is a string */
3499 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3501 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3503 SvFLAGS(dstr) &= ~SVf_OOK;
3504 Safefree(SvPVX(dstr) - SvIVX(dstr));
3506 else if (SvLEN(dstr))
3507 Safefree(SvPVX(dstr));
3509 (void)SvPOK_only(dstr);
3510 SvPV_set(dstr, SvPVX(sstr));
3511 SvLEN_set(dstr, SvLEN(sstr));
3512 SvCUR_set(dstr, SvCUR(sstr));
3515 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3516 SvPV_set(sstr, Nullch);
3521 else { /* have to copy actual string */
3522 STRLEN len = SvCUR(sstr);
3524 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3525 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3526 SvCUR_set(dstr, len);
3527 *SvEND(dstr) = '\0';
3528 (void)SvPOK_only(dstr);
3530 if (sflags & SVf_UTF8)
3533 if (sflags & SVp_NOK) {
3535 if (sflags & SVf_NOK)
3536 SvFLAGS(dstr) |= SVf_NOK;
3537 SvNVX(dstr) = SvNVX(sstr);
3539 if (sflags & SVp_IOK) {
3540 (void)SvIOKp_on(dstr);
3541 if (sflags & SVf_IOK)
3542 SvFLAGS(dstr) |= SVf_IOK;
3543 if (sflags & SVf_IVisUV)
3545 SvIVX(dstr) = SvIVX(sstr);
3548 else if (sflags & SVp_IOK) {
3549 if (sflags & SVf_IOK)
3550 (void)SvIOK_only(dstr);
3552 (void)SvOK_off(dstr);
3553 (void)SvIOKp_on(dstr);
3555 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3556 if (sflags & SVf_IVisUV)
3558 SvIVX(dstr) = SvIVX(sstr);
3559 if (sflags & SVp_NOK) {
3560 if (sflags & SVf_NOK)
3561 (void)SvNOK_on(dstr);
3563 (void)SvNOKp_on(dstr);
3564 SvNVX(dstr) = SvNVX(sstr);
3567 else if (sflags & SVp_NOK) {
3568 if (sflags & SVf_NOK)
3569 (void)SvNOK_only(dstr);
3571 (void)SvOK_off(dstr);
3574 SvNVX(dstr) = SvNVX(sstr);
3577 if (dtype == SVt_PVGV) {
3578 if (ckWARN(WARN_MISC))
3579 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3582 (void)SvOK_off(dstr);
3584 if (SvTAINTED(sstr))
3589 =for apidoc sv_setsv_mg
3591 Like C<sv_setsv>, but also handles 'set' magic.
3597 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3599 sv_setsv(dstr,sstr);
3604 =for apidoc sv_setpvn
3606 Copies a string into an SV. The C<len> parameter indicates the number of
3607 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3613 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3615 register char *dptr;
3617 SV_CHECK_THINKFIRST(sv);
3623 /* len is STRLEN which is unsigned, need to copy to signed */
3627 (void)SvUPGRADE(sv, SVt_PV);
3629 SvGROW(sv, len + 1);
3631 Move(ptr,dptr,len,char);
3634 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3639 =for apidoc sv_setpvn_mg
3641 Like C<sv_setpvn>, but also handles 'set' magic.
3647 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3649 sv_setpvn(sv,ptr,len);
3654 =for apidoc sv_setpv
3656 Copies a string into an SV. The string must be null-terminated. Does not
3657 handle 'set' magic. See C<sv_setpv_mg>.
3663 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3665 register STRLEN len;
3667 SV_CHECK_THINKFIRST(sv);
3673 (void)SvUPGRADE(sv, SVt_PV);
3675 SvGROW(sv, len + 1);
3676 Move(ptr,SvPVX(sv),len+1,char);
3678 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3683 =for apidoc sv_setpv_mg
3685 Like C<sv_setpv>, but also handles 'set' magic.
3691 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3698 =for apidoc sv_usepvn
3700 Tells an SV to use C<ptr> to find its string value. Normally the string is
3701 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3702 The C<ptr> should point to memory that was allocated by C<malloc>. The
3703 string length, C<len>, must be supplied. This function will realloc the
3704 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3705 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3706 See C<sv_usepvn_mg>.
3712 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3714 SV_CHECK_THINKFIRST(sv);
3715 (void)SvUPGRADE(sv, SVt_PV);
3720 (void)SvOOK_off(sv);
3721 if (SvPVX(sv) && SvLEN(sv))
3722 Safefree(SvPVX(sv));
3723 Renew(ptr, len+1, char);
3726 SvLEN_set(sv, len+1);
3728 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3733 =for apidoc sv_usepvn_mg
3735 Like C<sv_usepvn>, but also handles 'set' magic.
3741 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3743 sv_usepvn(sv,ptr,len);
3748 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3750 if (SvREADONLY(sv)) {
3752 char *pvx = SvPVX(sv);
3753 STRLEN len = SvCUR(sv);
3754 U32 hash = SvUVX(sv);
3755 SvGROW(sv, len + 1);
3756 Move(pvx,SvPVX(sv),len,char);
3760 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3762 else if (PL_curcop != &PL_compiling)
3763 Perl_croak(aTHX_ PL_no_modify);
3766 sv_unref_flags(sv, flags);
3767 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3772 Perl_sv_force_normal(pTHX_ register SV *sv)
3774 sv_force_normal_flags(sv, 0);
3780 Efficient removal of characters from the beginning of the string buffer.
3781 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3782 the string buffer. The C<ptr> becomes the first character of the adjusted
3789 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3793 register STRLEN delta;
3795 if (!ptr || !SvPOKp(sv))
3797 SV_CHECK_THINKFIRST(sv);
3798 if (SvTYPE(sv) < SVt_PVIV)
3799 sv_upgrade(sv,SVt_PVIV);
3802 if (!SvLEN(sv)) { /* make copy of shared string */
3803 char *pvx = SvPVX(sv);
3804 STRLEN len = SvCUR(sv);
3805 SvGROW(sv, len + 1);
3806 Move(pvx,SvPVX(sv),len,char);
3810 SvFLAGS(sv) |= SVf_OOK;
3812 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3813 delta = ptr - SvPVX(sv);
3821 =for apidoc sv_catpvn
3823 Concatenates the string onto the end of the string which is in the SV. The
3824 C<len> indicates number of bytes to copy. If the SV has the UTF8
3825 status set, then the bytes appended should be valid UTF8.
3826 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3832 Perl_sv_catpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3837 junk = SvPV_force(sv, tlen);
3838 SvGROW(sv, tlen + len + 1);
3841 Move(ptr,SvPVX(sv)+tlen,len,char);
3844 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3849 =for apidoc sv_catpvn_mg
3851 Like C<sv_catpvn>, but also handles 'set' magic.
3857 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3859 sv_catpvn(sv,ptr,len);
3864 =for apidoc sv_catsv
3866 Concatenates the string from SV C<ssv> onto the end of the string in
3867 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3868 not 'set' magic. See C<sv_catsv_mg>.
3873 Perl_sv_catsv(pTHX_ SV *dsv, register SV *ssv)
3879 if ((spv = SvPV(ssv, slen))) {
3880 bool dutf8 = DO_UTF8(dsv);
3881 bool sutf8 = DO_UTF8(ssv);
3884 sv_catpvn(dsv,spv,slen);
3887 /* Not modifying source SV, so taking a temporary copy. */
3888 SV* csv = sv_2mortal(newSVsv(ssv));
3892 sv_utf8_upgrade(csv);
3893 cpv = SvPV(csv,clen);
3894 sv_catpvn(dsv,cpv,clen);
3897 sv_utf8_upgrade(dsv);
3898 sv_catpvn(dsv,spv,slen);
3899 SvUTF8_on(dsv); /* If dsv has no wide characters. */
3906 =for apidoc sv_catsv_mg
3908 Like C<sv_catsv>, but also handles 'set' magic.
3914 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
3921 =for apidoc sv_catpv
3923 Concatenates the string onto the end of the string which is in the SV.
3924 If the SV has the UTF8 status set, then the bytes appended should be
3925 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
3930 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
3932 register STRLEN len;
3938 junk = SvPV_force(sv, tlen);
3940 SvGROW(sv, tlen + len + 1);
3943 Move(ptr,SvPVX(sv)+tlen,len+1,char);
3945 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3950 =for apidoc sv_catpv_mg
3952 Like C<sv_catpv>, but also handles 'set' magic.
3958 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
3965 Perl_newSV(pTHX_ STRLEN len)
3971 sv_upgrade(sv, SVt_PV);
3972 SvGROW(sv, len + 1);
3977 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
3980 =for apidoc sv_magic
3982 Adds magic to an SV.
3988 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
3992 if (SvREADONLY(sv)) {
3993 if (PL_curcop != &PL_compiling && !strchr("gBf", how))
3994 Perl_croak(aTHX_ PL_no_modify);
3996 if (SvMAGICAL(sv) || (how == 't' && SvTYPE(sv) >= SVt_PVMG)) {
3997 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4004 (void)SvUPGRADE(sv, SVt_PVMG);
4006 Newz(702,mg, 1, MAGIC);
4007 mg->mg_moremagic = SvMAGIC(sv);
4010 /* Some magic sontains a reference loop, where the sv and object refer to
4011 each other. To prevent a avoid a reference loop that would prevent such
4012 objects being freed, we look for such loops and if we find one we avoid
4013 incrementing the object refcount. */
4014 if (!obj || obj == sv || how == '#' || how == 'r' ||
4015 (SvTYPE(obj) == SVt_PVGV &&
4016 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4017 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4018 GvFORM(obj) == (CV*)sv)))
4023 mg->mg_obj = SvREFCNT_inc(obj);
4024 mg->mg_flags |= MGf_REFCOUNTED;
4027 mg->mg_len = namlen;
4030 mg->mg_ptr = savepvn(name, namlen);
4031 else if (namlen == HEf_SVKEY)
4032 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4037 mg->mg_virtual = &PL_vtbl_sv;
4040 mg->mg_virtual = &PL_vtbl_amagic;
4043 mg->mg_virtual = &PL_vtbl_amagicelem;
4046 mg->mg_virtual = &PL_vtbl_ovrld;
4049 mg->mg_virtual = &PL_vtbl_bm;
4052 mg->mg_virtual = &PL_vtbl_regdata;
4055 mg->mg_virtual = &PL_vtbl_regdatum;
4058 mg->mg_virtual = &PL_vtbl_env;
4061 mg->mg_virtual = &PL_vtbl_fm;
4064 mg->mg_virtual = &PL_vtbl_envelem;
4067 mg->mg_virtual = &PL_vtbl_mglob;
4070 mg->mg_virtual = &PL_vtbl_isa;
4073 mg->mg_virtual = &PL_vtbl_isaelem;
4076 mg->mg_virtual = &PL_vtbl_nkeys;
4083 mg->mg_virtual = &PL_vtbl_dbline;
4087 mg->mg_virtual = &PL_vtbl_mutex;
4089 #endif /* USE_THREADS */
4090 #ifdef USE_LOCALE_COLLATE
4092 mg->mg_virtual = &PL_vtbl_collxfrm;
4094 #endif /* USE_LOCALE_COLLATE */
4096 mg->mg_virtual = &PL_vtbl_pack;
4100 mg->mg_virtual = &PL_vtbl_packelem;
4103 mg->mg_virtual = &PL_vtbl_regexp;
4106 mg->mg_virtual = &PL_vtbl_sig;
4109 mg->mg_virtual = &PL_vtbl_sigelem;
4112 mg->mg_virtual = &PL_vtbl_taint;
4116 mg->mg_virtual = &PL_vtbl_uvar;
4119 mg->mg_virtual = &PL_vtbl_vec;
4122 mg->mg_virtual = &PL_vtbl_substr;
4125 mg->mg_virtual = &PL_vtbl_defelem;
4128 mg->mg_virtual = &PL_vtbl_glob;
4131 mg->mg_virtual = &PL_vtbl_arylen;
4134 mg->mg_virtual = &PL_vtbl_pos;
4137 mg->mg_virtual = &PL_vtbl_backref;
4139 case '~': /* Reserved for use by extensions not perl internals. */
4140 /* Useful for attaching extension internal data to perl vars. */
4141 /* Note that multiple extensions may clash if magical scalars */
4142 /* etc holding private data from one are passed to another. */
4146 Perl_croak(aTHX_ "Don't know how to handle magic of type '%c'", how);
4150 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4154 =for apidoc sv_unmagic
4156 Removes magic from an SV.
4162 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4166 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4169 for (mg = *mgp; mg; mg = *mgp) {
4170 if (mg->mg_type == type) {
4171 MGVTBL* vtbl = mg->mg_virtual;
4172 *mgp = mg->mg_moremagic;
4173 if (vtbl && vtbl->svt_free)
4174 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4175 if (mg->mg_ptr && mg->mg_type != 'g') {
4176 if (mg->mg_len >= 0)
4177 Safefree(mg->mg_ptr);
4178 else if (mg->mg_len == HEf_SVKEY)
4179 SvREFCNT_dec((SV*)mg->mg_ptr);
4181 if (mg->mg_flags & MGf_REFCOUNTED)
4182 SvREFCNT_dec(mg->mg_obj);
4186 mgp = &mg->mg_moremagic;
4190 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4197 =for apidoc sv_rvweaken
4205 Perl_sv_rvweaken(pTHX_ SV *sv)
4208 if (!SvOK(sv)) /* let undefs pass */
4211 Perl_croak(aTHX_ "Can't weaken a nonreference");
4212 else if (SvWEAKREF(sv)) {
4213 if (ckWARN(WARN_MISC))
4214 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4218 sv_add_backref(tsv, sv);
4225 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4229 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, '<')))
4230 av = (AV*)mg->mg_obj;
4233 sv_magic(tsv, (SV*)av, '<', NULL, 0);
4234 SvREFCNT_dec(av); /* for sv_magic */
4240 S_sv_del_backref(pTHX_ SV *sv)
4247 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, '<')))
4248 Perl_croak(aTHX_ "panic: del_backref");
4249 av = (AV *)mg->mg_obj;
4254 svp[i] = &PL_sv_undef; /* XXX */
4261 =for apidoc sv_insert
4263 Inserts a string at the specified offset/length within the SV. Similar to
4264 the Perl substr() function.
4270 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4274 register char *midend;
4275 register char *bigend;
4281 Perl_croak(aTHX_ "Can't modify non-existent substring");
4282 SvPV_force(bigstr, curlen);
4283 (void)SvPOK_only_UTF8(bigstr);
4284 if (offset + len > curlen) {
4285 SvGROW(bigstr, offset+len+1);
4286 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4287 SvCUR_set(bigstr, offset+len);
4291 i = littlelen - len;
4292 if (i > 0) { /* string might grow */
4293 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4294 mid = big + offset + len;
4295 midend = bigend = big + SvCUR(bigstr);
4298 while (midend > mid) /* shove everything down */
4299 *--bigend = *--midend;
4300 Move(little,big+offset,littlelen,char);
4306 Move(little,SvPVX(bigstr)+offset,len,char);
4311 big = SvPVX(bigstr);
4314 bigend = big + SvCUR(bigstr);
4316 if (midend > bigend)
4317 Perl_croak(aTHX_ "panic: sv_insert");
4319 if (mid - big > bigend - midend) { /* faster to shorten from end */
4321 Move(little, mid, littlelen,char);
4324 i = bigend - midend;
4326 Move(midend, mid, i,char);
4330 SvCUR_set(bigstr, mid - big);
4333 else if ((i = mid - big)) { /* faster from front */
4334 midend -= littlelen;
4336 sv_chop(bigstr,midend-i);
4341 Move(little, mid, littlelen,char);
4343 else if (littlelen) {
4344 midend -= littlelen;
4345 sv_chop(bigstr,midend);
4346 Move(little,midend,littlelen,char);
4349 sv_chop(bigstr,midend);
4355 =for apidoc sv_replace
4357 Make the first argument a copy of the second, then delete the original.
4363 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4365 U32 refcnt = SvREFCNT(sv);
4366 SV_CHECK_THINKFIRST(sv);
4367 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4368 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4369 if (SvMAGICAL(sv)) {
4373 sv_upgrade(nsv, SVt_PVMG);
4374 SvMAGIC(nsv) = SvMAGIC(sv);
4375 SvFLAGS(nsv) |= SvMAGICAL(sv);
4381 assert(!SvREFCNT(sv));
4382 StructCopy(nsv,sv,SV);
4383 SvREFCNT(sv) = refcnt;
4384 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4389 =for apidoc sv_clear
4391 Clear an SV, making it empty. Does not free the memory used by the SV
4398 Perl_sv_clear(pTHX_ register SV *sv)
4402 assert(SvREFCNT(sv) == 0);
4405 if (PL_defstash) { /* Still have a symbol table? */
4410 Zero(&tmpref, 1, SV);
4411 sv_upgrade(&tmpref, SVt_RV);
4413 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4414 SvREFCNT(&tmpref) = 1;
4417 stash = SvSTASH(sv);
4418 destructor = StashHANDLER(stash,DESTROY);
4421 PUSHSTACKi(PERLSI_DESTROY);
4422 SvRV(&tmpref) = SvREFCNT_inc(sv);
4427 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4433 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4435 del_XRV(SvANY(&tmpref));
4438 if (PL_in_clean_objs)
4439 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4441 /* DESTROY gave object new lease on life */
4447 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4448 SvOBJECT_off(sv); /* Curse the object. */
4449 if (SvTYPE(sv) != SVt_PVIO)
4450 --PL_sv_objcount; /* XXX Might want something more general */
4453 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv))
4456 switch (SvTYPE(sv)) {
4459 IoIFP(sv) != PerlIO_stdin() &&
4460 IoIFP(sv) != PerlIO_stdout() &&
4461 IoIFP(sv) != PerlIO_stderr())
4463 io_close((IO*)sv, FALSE);
4465 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4466 PerlDir_close(IoDIRP(sv));
4467 IoDIRP(sv) = (DIR*)NULL;
4468 Safefree(IoTOP_NAME(sv));
4469 Safefree(IoFMT_NAME(sv));
4470 Safefree(IoBOTTOM_NAME(sv));
4485 SvREFCNT_dec(LvTARG(sv));
4489 Safefree(GvNAME(sv));
4490 /* cannot decrease stash refcount yet, as we might recursively delete
4491 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4492 of stash until current sv is completely gone.
4493 -- JohnPC, 27 Mar 1998 */
4494 stash = GvSTASH(sv);
4500 (void)SvOOK_off(sv);
4508 SvREFCNT_dec(SvRV(sv));
4510 else if (SvPVX(sv) && SvLEN(sv))
4511 Safefree(SvPVX(sv));
4512 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4513 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4525 switch (SvTYPE(sv)) {
4541 del_XPVIV(SvANY(sv));
4544 del_XPVNV(SvANY(sv));
4547 del_XPVMG(SvANY(sv));
4550 del_XPVLV(SvANY(sv));
4553 del_XPVAV(SvANY(sv));
4556 del_XPVHV(SvANY(sv));
4559 del_XPVCV(SvANY(sv));
4562 del_XPVGV(SvANY(sv));
4563 /* code duplication for increased performance. */
4564 SvFLAGS(sv) &= SVf_BREAK;
4565 SvFLAGS(sv) |= SVTYPEMASK;
4566 /* decrease refcount of the stash that owns this GV, if any */
4568 SvREFCNT_dec(stash);
4569 return; /* not break, SvFLAGS reset already happened */
4571 del_XPVBM(SvANY(sv));
4574 del_XPVFM(SvANY(sv));
4577 del_XPVIO(SvANY(sv));
4580 SvFLAGS(sv) &= SVf_BREAK;
4581 SvFLAGS(sv) |= SVTYPEMASK;
4585 Perl_sv_newref(pTHX_ SV *sv)
4588 ATOMIC_INC(SvREFCNT(sv));
4595 Free the memory used by an SV.
4601 Perl_sv_free(pTHX_ SV *sv)
4603 int refcount_is_zero;
4607 if (SvREFCNT(sv) == 0) {
4608 if (SvFLAGS(sv) & SVf_BREAK)
4610 if (PL_in_clean_all) /* All is fair */
4612 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4613 /* make sure SvREFCNT(sv)==0 happens very seldom */
4614 SvREFCNT(sv) = (~(U32)0)/2;
4617 if (ckWARN_d(WARN_INTERNAL))
4618 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4621 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4622 if (!refcount_is_zero)
4626 if (ckWARN_d(WARN_DEBUGGING))
4627 Perl_warner(aTHX_ WARN_DEBUGGING,
4628 "Attempt to free temp prematurely: SV 0x%"UVxf,
4633 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4634 /* make sure SvREFCNT(sv)==0 happens very seldom */
4635 SvREFCNT(sv) = (~(U32)0)/2;
4646 Returns the length of the string in the SV. See also C<SvCUR>.
4652 Perl_sv_len(pTHX_ register SV *sv)
4661 len = mg_length(sv);
4663 junk = SvPV(sv, len);
4668 =for apidoc sv_len_utf8
4670 Returns the number of characters in the string in an SV, counting wide
4671 UTF8 bytes as a single character.
4677 Perl_sv_len_utf8(pTHX_ register SV *sv)
4683 return mg_length(sv);
4687 U8 *s = (U8*)SvPV(sv, len);
4689 return Perl_utf8_length(aTHX_ s, s + len);
4694 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4699 I32 uoffset = *offsetp;
4705 start = s = (U8*)SvPV(sv, len);
4707 while (s < send && uoffset--)
4711 *offsetp = s - start;
4715 while (s < send && ulen--)
4725 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4734 s = (U8*)SvPV(sv, len);
4736 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4737 send = s + *offsetp;
4741 /* Call utf8n_to_uvchr() to validate the sequence */
4742 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4757 Returns a boolean indicating whether the strings in the two SVs are
4764 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4778 pv1 = SvPV(sv1, cur1);
4785 pv2 = SvPV(sv2, cur2);
4787 /* do not utf8ize the comparands as a side-effect */
4788 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4789 bool is_utf8 = TRUE;
4790 /* UTF-8ness differs */
4791 if (PL_hints & HINT_UTF8_DISTINCT)
4795 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4796 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4801 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4802 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4807 /* Downgrade not possible - cannot be eq */
4813 eq = memEQ(pv1, pv2, cur1);
4824 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4825 string in C<sv1> is less than, equal to, or greater than the string in
4832 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4837 bool pv1tmp = FALSE;
4838 bool pv2tmp = FALSE;
4845 pv1 = SvPV(sv1, cur1);
4852 pv2 = SvPV(sv2, cur2);
4854 /* do not utf8ize the comparands as a side-effect */
4855 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTE) {
4856 if (PL_hints & HINT_UTF8_DISTINCT)
4857 return SvUTF8(sv1) ? 1 : -1;
4860 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4864 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4870 cmp = cur2 ? -1 : 0;
4874 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4877 cmp = retval < 0 ? -1 : 1;
4878 } else if (cur1 == cur2) {
4881 cmp = cur1 < cur2 ? -1 : 1;
4894 =for apidoc sv_cmp_locale
4896 Compares the strings in two SVs in a locale-aware manner. See
4903 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
4905 #ifdef USE_LOCALE_COLLATE
4911 if (PL_collation_standard)
4915 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
4917 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
4919 if (!pv1 || !len1) {
4930 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
4933 return retval < 0 ? -1 : 1;
4936 * When the result of collation is equality, that doesn't mean
4937 * that there are no differences -- some locales exclude some
4938 * characters from consideration. So to avoid false equalities,
4939 * we use the raw string as a tiebreaker.
4945 #endif /* USE_LOCALE_COLLATE */
4947 return sv_cmp(sv1, sv2);
4950 #ifdef USE_LOCALE_COLLATE
4952 * Any scalar variable may carry an 'o' magic that contains the
4953 * scalar data of the variable transformed to such a format that
4954 * a normal memory comparison can be used to compare the data
4955 * according to the locale settings.
4958 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
4962 mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : (MAGIC *) NULL;
4963 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
4968 Safefree(mg->mg_ptr);
4970 if ((xf = mem_collxfrm(s, len, &xlen))) {
4971 if (SvREADONLY(sv)) {
4974 return xf + sizeof(PL_collation_ix);
4977 sv_magic(sv, 0, 'o', 0, 0);
4978 mg = mg_find(sv, 'o');
4991 if (mg && mg->mg_ptr) {
4993 return mg->mg_ptr + sizeof(PL_collation_ix);
5001 #endif /* USE_LOCALE_COLLATE */
5006 Get a line from the filehandle and store it into the SV, optionally
5007 appending to the currently-stored string.
5013 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5017 register STDCHAR rslast;
5018 register STDCHAR *bp;
5022 SV_CHECK_THINKFIRST(sv);
5023 (void)SvUPGRADE(sv, SVt_PV);
5027 if (RsSNARF(PL_rs)) {
5031 else if (RsRECORD(PL_rs)) {
5032 I32 recsize, bytesread;
5035 /* Grab the size of the record we're getting */
5036 recsize = SvIV(SvRV(PL_rs));
5037 (void)SvPOK_only(sv); /* Validate pointer */
5038 buffer = SvGROW(sv, recsize + 1);
5041 /* VMS wants read instead of fread, because fread doesn't respect */
5042 /* RMS record boundaries. This is not necessarily a good thing to be */
5043 /* doing, but we've got no other real choice */
5044 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5046 bytesread = PerlIO_read(fp, buffer, recsize);
5048 SvCUR_set(sv, bytesread);
5049 buffer[bytesread] = '\0';
5050 if (PerlIO_isutf8(fp))
5054 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5056 else if (RsPARA(PL_rs)) {
5061 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5062 if (PerlIO_isutf8(fp)) {
5063 rsptr = SvPVutf8(PL_rs, rslen);
5066 if (SvUTF8(PL_rs)) {
5067 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5068 Perl_croak(aTHX_ "Wide character in $/");
5071 rsptr = SvPV(PL_rs, rslen);
5075 rslast = rslen ? rsptr[rslen - 1] : '\0';
5077 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5078 do { /* to make sure file boundaries work right */
5081 i = PerlIO_getc(fp);
5085 PerlIO_ungetc(fp,i);
5091 /* See if we know enough about I/O mechanism to cheat it ! */
5093 /* This used to be #ifdef test - it is made run-time test for ease
5094 of abstracting out stdio interface. One call should be cheap
5095 enough here - and may even be a macro allowing compile
5099 if (PerlIO_fast_gets(fp)) {
5102 * We're going to steal some values from the stdio struct
5103 * and put EVERYTHING in the innermost loop into registers.
5105 register STDCHAR *ptr;
5109 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5110 /* An ungetc()d char is handled separately from the regular
5111 * buffer, so we getc() it back out and stuff it in the buffer.
5113 i = PerlIO_getc(fp);
5114 if (i == EOF) return 0;
5115 *(--((*fp)->_ptr)) = (unsigned char) i;
5119 /* Here is some breathtakingly efficient cheating */
5121 cnt = PerlIO_get_cnt(fp); /* get count into register */
5122 (void)SvPOK_only(sv); /* validate pointer */
5123 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5124 if (cnt > 80 && SvLEN(sv) > append) {
5125 shortbuffered = cnt - SvLEN(sv) + append + 1;
5126 cnt -= shortbuffered;
5130 /* remember that cnt can be negative */
5131 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5136 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5137 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5138 DEBUG_P(PerlIO_printf(Perl_debug_log,
5139 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5140 DEBUG_P(PerlIO_printf(Perl_debug_log,
5141 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5142 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5143 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5148 while (cnt > 0) { /* this | eat */
5150 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5151 goto thats_all_folks; /* screams | sed :-) */
5155 Copy(ptr, bp, cnt, char); /* this | eat */
5156 bp += cnt; /* screams | dust */
5157 ptr += cnt; /* louder | sed :-) */
5162 if (shortbuffered) { /* oh well, must extend */
5163 cnt = shortbuffered;
5165 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5167 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5168 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5172 DEBUG_P(PerlIO_printf(Perl_debug_log,
5173 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5174 PTR2UV(ptr),(long)cnt));
5175 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5176 DEBUG_P(PerlIO_printf(Perl_debug_log,
5177 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5178 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5179 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5180 /* This used to call 'filbuf' in stdio form, but as that behaves like
5181 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5182 another abstraction. */
5183 i = PerlIO_getc(fp); /* get more characters */
5184 DEBUG_P(PerlIO_printf(Perl_debug_log,
5185 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5186 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5187 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5188 cnt = PerlIO_get_cnt(fp);
5189 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5190 DEBUG_P(PerlIO_printf(Perl_debug_log,
5191 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5193 if (i == EOF) /* all done for ever? */
5194 goto thats_really_all_folks;
5196 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5198 SvGROW(sv, bpx + cnt + 2);
5199 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5201 *bp++ = i; /* store character from PerlIO_getc */
5203 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5204 goto thats_all_folks;
5208 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5209 memNE((char*)bp - rslen, rsptr, rslen))
5210 goto screamer; /* go back to the fray */
5211 thats_really_all_folks:
5213 cnt += shortbuffered;
5214 DEBUG_P(PerlIO_printf(Perl_debug_log,
5215 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5216 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5217 DEBUG_P(PerlIO_printf(Perl_debug_log,
5218 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5219 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5220 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5222 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5223 DEBUG_P(PerlIO_printf(Perl_debug_log,
5224 "Screamer: done, len=%ld, string=|%.*s|\n",
5225 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5230 /*The big, slow, and stupid way */
5233 /* Need to work around EPOC SDK features */
5234 /* On WINS: MS VC5 generates calls to _chkstk, */
5235 /* if a `large' stack frame is allocated */
5236 /* gcc on MARM does not generate calls like these */
5242 register STDCHAR *bpe = buf + sizeof(buf);
5244 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5245 ; /* keep reading */
5249 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5250 /* Accomodate broken VAXC compiler, which applies U8 cast to
5251 * both args of ?: operator, causing EOF to change into 255
5253 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5257 sv_catpvn(sv, (char *) buf, cnt);
5259 sv_setpvn(sv, (char *) buf, cnt);
5261 if (i != EOF && /* joy */
5263 SvCUR(sv) < rslen ||
5264 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5268 * If we're reading from a TTY and we get a short read,
5269 * indicating that the user hit his EOF character, we need
5270 * to notice it now, because if we try to read from the TTY
5271 * again, the EOF condition will disappear.
5273 * The comparison of cnt to sizeof(buf) is an optimization
5274 * that prevents unnecessary calls to feof().
5278 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5283 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5284 while (i != EOF) { /* to make sure file boundaries work right */
5285 i = PerlIO_getc(fp);
5287 PerlIO_ungetc(fp,i);
5293 if (PerlIO_isutf8(fp))
5298 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5305 Auto-increment of the value in the SV.
5311 Perl_sv_inc(pTHX_ register SV *sv)
5320 if (SvTHINKFIRST(sv)) {
5321 if (SvREADONLY(sv)) {
5322 if (PL_curcop != &PL_compiling)
5323 Perl_croak(aTHX_ PL_no_modify);
5327 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5329 i = PTR2IV(SvRV(sv));
5334 flags = SvFLAGS(sv);
5335 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5336 /* It's (privately or publicly) a float, but not tested as an
5337 integer, so test it to see. */
5339 flags = SvFLAGS(sv);
5341 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5342 /* It's publicly an integer, or privately an integer-not-float */
5345 if (SvUVX(sv) == UV_MAX)
5346 sv_setnv(sv, (NV)UV_MAX + 1.0);
5348 (void)SvIOK_only_UV(sv);
5351 if (SvIVX(sv) == IV_MAX)
5352 sv_setuv(sv, (UV)IV_MAX + 1);
5354 (void)SvIOK_only(sv);
5360 if (flags & SVp_NOK) {
5361 (void)SvNOK_only(sv);
5366 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5367 if ((flags & SVTYPEMASK) < SVt_PVIV)
5368 sv_upgrade(sv, SVt_IV);
5369 (void)SvIOK_only(sv);
5374 while (isALPHA(*d)) d++;
5375 while (isDIGIT(*d)) d++;
5377 #ifdef PERL_PRESERVE_IVUV
5378 /* Got to punt this an an integer if needs be, but we don't issue
5379 warnings. Probably ought to make the sv_iv_please() that does
5380 the conversion if possible, and silently. */
5381 I32 numtype = looks_like_number(sv);
5382 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5383 /* Need to try really hard to see if it's an integer.
5384 9.22337203685478e+18 is an integer.
5385 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5386 so $a="9.22337203685478e+18"; $a+0; $a++
5387 needs to be the same as $a="9.22337203685478e+18"; $a++
5394 /* sv_2iv *should* have made this an NV */
5395 if (flags & SVp_NOK) {
5396 (void)SvNOK_only(sv);
5400 /* I don't think we can get here. Maybe I should assert this
5401 And if we do get here I suspect that sv_setnv will croak. NWC
5403 #if defined(USE_LONG_DOUBLE)
5404 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",
5405 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5407 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5408 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5411 #endif /* PERL_PRESERVE_IVUV */
5412 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5416 while (d >= SvPVX(sv)) {
5424 /* MKS: The original code here died if letters weren't consecutive.
5425 * at least it didn't have to worry about non-C locales. The
5426 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5427 * arranged in order (although not consecutively) and that only
5428 * [A-Za-z] are accepted by isALPHA in the C locale.
5430 if (*d != 'z' && *d != 'Z') {
5431 do { ++*d; } while (!isALPHA(*d));
5434 *(d--) -= 'z' - 'a';
5439 *(d--) -= 'z' - 'a' + 1;
5443 /* oh,oh, the number grew */
5444 SvGROW(sv, SvCUR(sv) + 2);
5446 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5457 Auto-decrement of the value in the SV.
5463 Perl_sv_dec(pTHX_ register SV *sv)
5471 if (SvTHINKFIRST(sv)) {
5472 if (SvREADONLY(sv)) {
5473 if (PL_curcop != &PL_compiling)
5474 Perl_croak(aTHX_ PL_no_modify);
5478 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5480 i = PTR2IV(SvRV(sv));
5485 /* Unlike sv_inc we don't have to worry about string-never-numbers
5486 and keeping them magic. But we mustn't warn on punting */
5487 flags = SvFLAGS(sv);
5488 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5489 /* It's publicly an integer, or privately an integer-not-float */
5492 if (SvUVX(sv) == 0) {
5493 (void)SvIOK_only(sv);
5497 (void)SvIOK_only_UV(sv);
5501 if (SvIVX(sv) == IV_MIN)
5502 sv_setnv(sv, (NV)IV_MIN - 1.0);
5504 (void)SvIOK_only(sv);
5510 if (flags & SVp_NOK) {
5512 (void)SvNOK_only(sv);
5515 if (!(flags & SVp_POK)) {
5516 if ((flags & SVTYPEMASK) < SVt_PVNV)
5517 sv_upgrade(sv, SVt_NV);
5519 (void)SvNOK_only(sv);
5522 #ifdef PERL_PRESERVE_IVUV
5524 I32 numtype = looks_like_number(sv);
5525 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5526 /* Need to try really hard to see if it's an integer.
5527 9.22337203685478e+18 is an integer.
5528 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5529 so $a="9.22337203685478e+18"; $a+0; $a--
5530 needs to be the same as $a="9.22337203685478e+18"; $a--
5537 /* sv_2iv *should* have made this an NV */
5538 if (flags & SVp_NOK) {
5539 (void)SvNOK_only(sv);
5543 /* I don't think we can get here. Maybe I should assert this
5544 And if we do get here I suspect that sv_setnv will croak. NWC
5546 #if defined(USE_LONG_DOUBLE)
5547 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",
5548 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5550 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5551 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5555 #endif /* PERL_PRESERVE_IVUV */
5556 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5560 =for apidoc sv_mortalcopy
5562 Creates a new SV which is a copy of the original SV. The new SV is marked
5568 /* Make a string that will exist for the duration of the expression
5569 * evaluation. Actually, it may have to last longer than that, but
5570 * hopefully we won't free it until it has been assigned to a
5571 * permanent location. */
5574 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5579 sv_setsv(sv,oldstr);
5581 PL_tmps_stack[++PL_tmps_ix] = sv;
5587 =for apidoc sv_newmortal
5589 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5595 Perl_sv_newmortal(pTHX)
5600 SvFLAGS(sv) = SVs_TEMP;
5602 PL_tmps_stack[++PL_tmps_ix] = sv;
5607 =for apidoc sv_2mortal
5609 Marks an SV as mortal. The SV will be destroyed when the current context
5615 /* same thing without the copying */
5618 Perl_sv_2mortal(pTHX_ register SV *sv)
5622 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5625 PL_tmps_stack[++PL_tmps_ix] = sv;
5633 Creates a new SV and copies a string into it. The reference count for the
5634 SV is set to 1. If C<len> is zero, Perl will compute the length using
5635 strlen(). For efficiency, consider using C<newSVpvn> instead.
5641 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5648 sv_setpvn(sv,s,len);
5653 =for apidoc newSVpvn
5655 Creates a new SV and copies a string into it. The reference count for the
5656 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5657 string. You are responsible for ensuring that the source string is at least
5664 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5669 sv_setpvn(sv,s,len);
5674 =for apidoc newSVpvn_share
5676 Creates a new SV and populates it with a string from
5677 the string table. Turns on READONLY and FAKE.
5678 The idea here is that as string table is used for shared hash
5679 keys these strings will have SvPVX == HeKEY and hash lookup
5680 will avoid string compare.
5686 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5689 bool is_utf8 = FALSE;
5694 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5695 STRLEN tmplen = len;
5696 /* See the note in hv.c:hv_fetch() --jhi */
5697 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5701 PERL_HASH(hash, src, len);
5703 sv_upgrade(sv, SVt_PVIV);
5704 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5716 #if defined(PERL_IMPLICIT_CONTEXT)
5718 Perl_newSVpvf_nocontext(const char* pat, ...)
5723 va_start(args, pat);
5724 sv = vnewSVpvf(pat, &args);
5731 =for apidoc newSVpvf
5733 Creates a new SV an initialize it with the string formatted like
5740 Perl_newSVpvf(pTHX_ const char* pat, ...)
5744 va_start(args, pat);
5745 sv = vnewSVpvf(pat, &args);
5751 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5755 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5762 Creates a new SV and copies a floating point value into it.
5763 The reference count for the SV is set to 1.
5769 Perl_newSVnv(pTHX_ NV n)
5781 Creates a new SV and copies an integer into it. The reference count for the
5788 Perl_newSViv(pTHX_ IV i)
5800 Creates a new SV and copies an unsigned integer into it.
5801 The reference count for the SV is set to 1.
5807 Perl_newSVuv(pTHX_ UV u)
5817 =for apidoc newRV_noinc
5819 Creates an RV wrapper for an SV. The reference count for the original
5820 SV is B<not> incremented.
5826 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5831 sv_upgrade(sv, SVt_RV);
5838 /* newRV_inc is #defined to newRV in sv.h */
5840 Perl_newRV(pTHX_ SV *tmpRef)
5842 return newRV_noinc(SvREFCNT_inc(tmpRef));
5848 Creates a new SV which is an exact duplicate of the original SV.
5853 /* make an exact duplicate of old */
5856 Perl_newSVsv(pTHX_ register SV *old)
5862 if (SvTYPE(old) == SVTYPEMASK) {
5863 if (ckWARN_d(WARN_INTERNAL))
5864 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5879 Perl_sv_reset(pTHX_ register char *s, HV *stash)
5887 char todo[PERL_UCHAR_MAX+1];
5892 if (!*s) { /* reset ?? searches */
5893 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
5894 pm->op_pmdynflags &= ~PMdf_USED;
5899 /* reset variables */
5901 if (!HvARRAY(stash))
5904 Zero(todo, 256, char);
5906 i = (unsigned char)*s;
5910 max = (unsigned char)*s++;
5911 for ( ; i <= max; i++) {
5914 for (i = 0; i <= (I32) HvMAX(stash); i++) {
5915 for (entry = HvARRAY(stash)[i];
5917 entry = HeNEXT(entry))
5919 if (!todo[(U8)*HeKEY(entry)])
5921 gv = (GV*)HeVAL(entry);
5923 if (SvTHINKFIRST(sv)) {
5924 if (!SvREADONLY(sv) && SvROK(sv))
5929 if (SvTYPE(sv) >= SVt_PV) {
5931 if (SvPVX(sv) != Nullch)
5938 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
5940 #ifdef USE_ENVIRON_ARRAY
5942 environ[0] = Nullch;
5951 Perl_sv_2io(pTHX_ SV *sv)
5957 switch (SvTYPE(sv)) {
5965 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
5969 Perl_croak(aTHX_ PL_no_usym, "filehandle");
5971 return sv_2io(SvRV(sv));
5972 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
5978 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
5985 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
5992 return *gvp = Nullgv, Nullcv;
5993 switch (SvTYPE(sv)) {
6012 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6013 tryAMAGICunDEREF(to_cv);
6016 if (SvTYPE(sv) == SVt_PVCV) {
6025 Perl_croak(aTHX_ "Not a subroutine reference");
6030 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6036 if (lref && !GvCVu(gv)) {
6039 tmpsv = NEWSV(704,0);
6040 gv_efullname3(tmpsv, gv, Nullch);
6041 /* XXX this is probably not what they think they're getting.
6042 * It has the same effect as "sub name;", i.e. just a forward
6044 newSUB(start_subparse(FALSE, 0),
6045 newSVOP(OP_CONST, 0, tmpsv),
6050 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6059 Returns true if the SV has a true value by Perl's rules.
6065 Perl_sv_true(pTHX_ register SV *sv)
6071 if ((tXpv = (XPV*)SvANY(sv)) &&
6072 (tXpv->xpv_cur > 1 ||
6073 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6080 return SvIVX(sv) != 0;
6083 return SvNVX(sv) != 0.0;
6085 return sv_2bool(sv);
6091 Perl_sv_iv(pTHX_ register SV *sv)
6095 return (IV)SvUVX(sv);
6102 Perl_sv_uv(pTHX_ register SV *sv)
6107 return (UV)SvIVX(sv);
6113 Perl_sv_nv(pTHX_ register SV *sv)
6121 Perl_sv_pv(pTHX_ SV *sv)
6128 return sv_2pv(sv, &n_a);
6132 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6138 return sv_2pv(sv, lp);
6142 =for apidoc sv_pvn_force
6144 Get a sensible string out of the SV somehow.
6150 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6154 if (SvTHINKFIRST(sv) && !SvROK(sv))
6155 sv_force_normal(sv);
6161 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6162 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6163 PL_op_name[PL_op->op_type]);
6167 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6172 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6173 SvGROW(sv, len + 1);
6174 Move(s,SvPVX(sv),len,char);
6179 SvPOK_on(sv); /* validate pointer */
6181 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6182 PTR2UV(sv),SvPVX(sv)));
6189 Perl_sv_pvbyte(pTHX_ SV *sv)
6191 sv_utf8_downgrade(sv,0);
6196 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6198 sv_utf8_downgrade(sv,0);
6199 return sv_pvn(sv,lp);
6203 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6205 sv_utf8_downgrade(sv,0);
6206 return sv_pvn_force(sv,lp);
6210 Perl_sv_pvutf8(pTHX_ SV *sv)
6212 sv_utf8_upgrade(sv);
6217 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6219 sv_utf8_upgrade(sv);
6220 return sv_pvn(sv,lp);
6224 =for apidoc sv_pvutf8n_force
6226 Get a sensible UTF8-encoded string out of the SV somehow. See
6233 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6235 sv_utf8_upgrade(sv);
6236 return sv_pvn_force(sv,lp);
6240 =for apidoc sv_reftype
6242 Returns a string describing what the SV is a reference to.
6248 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6250 if (ob && SvOBJECT(sv))
6251 return HvNAME(SvSTASH(sv));
6253 switch (SvTYPE(sv)) {
6267 case SVt_PVLV: return "LVALUE";
6268 case SVt_PVAV: return "ARRAY";
6269 case SVt_PVHV: return "HASH";
6270 case SVt_PVCV: return "CODE";
6271 case SVt_PVGV: return "GLOB";
6272 case SVt_PVFM: return "FORMAT";
6273 case SVt_PVIO: return "IO";
6274 default: return "UNKNOWN";
6280 =for apidoc sv_isobject
6282 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6283 object. If the SV is not an RV, or if the object is not blessed, then this
6290 Perl_sv_isobject(pTHX_ SV *sv)
6307 Returns a boolean indicating whether the SV is blessed into the specified
6308 class. This does not check for subtypes; use C<sv_derived_from> to verify
6309 an inheritance relationship.
6315 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6327 return strEQ(HvNAME(SvSTASH(sv)), name);
6333 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6334 it will be upgraded to one. If C<classname> is non-null then the new SV will
6335 be blessed in the specified package. The new SV is returned and its
6336 reference count is 1.
6342 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6348 SV_CHECK_THINKFIRST(rv);
6351 if (SvTYPE(rv) >= SVt_PVMG) {
6352 U32 refcnt = SvREFCNT(rv);
6356 SvREFCNT(rv) = refcnt;
6359 if (SvTYPE(rv) < SVt_RV)
6360 sv_upgrade(rv, SVt_RV);
6361 else if (SvTYPE(rv) > SVt_RV) {
6362 (void)SvOOK_off(rv);
6363 if (SvPVX(rv) && SvLEN(rv))
6364 Safefree(SvPVX(rv));
6374 HV* stash = gv_stashpv(classname, TRUE);
6375 (void)sv_bless(rv, stash);
6381 =for apidoc sv_setref_pv
6383 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6384 argument will be upgraded to an RV. That RV will be modified to point to
6385 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6386 into the SV. The C<classname> argument indicates the package for the
6387 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6388 will be returned and will have a reference count of 1.
6390 Do not use with other Perl types such as HV, AV, SV, CV, because those
6391 objects will become corrupted by the pointer copy process.
6393 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6399 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6402 sv_setsv(rv, &PL_sv_undef);
6406 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6411 =for apidoc sv_setref_iv
6413 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6414 argument will be upgraded to an RV. That RV will be modified to point to
6415 the new SV. The C<classname> argument indicates the package for the
6416 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6417 will be returned and will have a reference count of 1.
6423 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6425 sv_setiv(newSVrv(rv,classname), iv);
6430 =for apidoc sv_setref_uv
6432 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6433 argument will be upgraded to an RV. That RV will be modified to point to
6434 the new SV. The C<classname> argument indicates the package for the
6435 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6436 will be returned and will have a reference count of 1.
6442 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6444 sv_setuv(newSVrv(rv,classname), uv);
6449 =for apidoc sv_setref_nv
6451 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6452 argument will be upgraded to an RV. That RV will be modified to point to
6453 the new SV. The C<classname> argument indicates the package for the
6454 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6455 will be returned and will have a reference count of 1.
6461 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6463 sv_setnv(newSVrv(rv,classname), nv);
6468 =for apidoc sv_setref_pvn
6470 Copies a string into a new SV, optionally blessing the SV. The length of the
6471 string must be specified with C<n>. The C<rv> argument will be upgraded to
6472 an RV. That RV will be modified to point to the new SV. The C<classname>
6473 argument indicates the package for the blessing. Set C<classname> to
6474 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6475 a reference count of 1.
6477 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6483 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6485 sv_setpvn(newSVrv(rv,classname), pv, n);
6490 =for apidoc sv_bless
6492 Blesses an SV into a specified package. The SV must be an RV. The package
6493 must be designated by its stash (see C<gv_stashpv()>). The reference count
6494 of the SV is unaffected.
6500 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6504 Perl_croak(aTHX_ "Can't bless non-reference value");
6506 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6507 if (SvREADONLY(tmpRef))
6508 Perl_croak(aTHX_ PL_no_modify);
6509 if (SvOBJECT(tmpRef)) {
6510 if (SvTYPE(tmpRef) != SVt_PVIO)
6512 SvREFCNT_dec(SvSTASH(tmpRef));
6515 SvOBJECT_on(tmpRef);
6516 if (SvTYPE(tmpRef) != SVt_PVIO)
6518 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6519 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6530 S_sv_unglob(pTHX_ SV *sv)
6534 assert(SvTYPE(sv) == SVt_PVGV);
6539 SvREFCNT_dec(GvSTASH(sv));
6540 GvSTASH(sv) = Nullhv;
6542 sv_unmagic(sv, '*');
6543 Safefree(GvNAME(sv));
6546 /* need to keep SvANY(sv) in the right arena */
6547 xpvmg = new_XPVMG();
6548 StructCopy(SvANY(sv), xpvmg, XPVMG);
6549 del_XPVGV(SvANY(sv));
6552 SvFLAGS(sv) &= ~SVTYPEMASK;
6553 SvFLAGS(sv) |= SVt_PVMG;
6557 =for apidoc sv_unref_flags
6559 Unsets the RV status of the SV, and decrements the reference count of
6560 whatever was being referenced by the RV. This can almost be thought of
6561 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6562 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6563 (otherwise the decrementing is conditional on the reference count being
6564 different from one or the reference being a readonly SV).
6571 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6575 if (SvWEAKREF(sv)) {
6583 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6585 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6586 sv_2mortal(rv); /* Schedule for freeing later */
6590 =for apidoc sv_unref
6592 Unsets the RV status of the SV, and decrements the reference count of
6593 whatever was being referenced by the RV. This can almost be thought of
6594 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6595 being zero. See C<SvROK_off>.
6601 Perl_sv_unref(pTHX_ SV *sv)
6603 sv_unref_flags(sv, 0);
6607 Perl_sv_taint(pTHX_ SV *sv)
6609 sv_magic((sv), Nullsv, 't', Nullch, 0);
6613 Perl_sv_untaint(pTHX_ SV *sv)
6615 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6616 MAGIC *mg = mg_find(sv, 't');
6623 Perl_sv_tainted(pTHX_ SV *sv)
6625 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6626 MAGIC *mg = mg_find(sv, 't');
6627 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6634 =for apidoc sv_setpviv
6636 Copies an integer into the given SV, also updating its string value.
6637 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6643 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6645 char buf[TYPE_CHARS(UV)];
6647 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6649 sv_setpvn(sv, ptr, ebuf - ptr);
6654 =for apidoc sv_setpviv_mg
6656 Like C<sv_setpviv>, but also handles 'set' magic.
6662 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6664 char buf[TYPE_CHARS(UV)];
6666 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6668 sv_setpvn(sv, ptr, ebuf - ptr);
6672 #if defined(PERL_IMPLICIT_CONTEXT)
6674 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6678 va_start(args, pat);
6679 sv_vsetpvf(sv, pat, &args);
6685 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6689 va_start(args, pat);
6690 sv_vsetpvf_mg(sv, pat, &args);
6696 =for apidoc sv_setpvf
6698 Processes its arguments like C<sprintf> and sets an SV to the formatted
6699 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6705 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6708 va_start(args, pat);
6709 sv_vsetpvf(sv, pat, &args);
6714 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6716 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6720 =for apidoc sv_setpvf_mg
6722 Like C<sv_setpvf>, but also handles 'set' magic.
6728 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6731 va_start(args, pat);
6732 sv_vsetpvf_mg(sv, pat, &args);
6737 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6739 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6743 #if defined(PERL_IMPLICIT_CONTEXT)
6745 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6749 va_start(args, pat);
6750 sv_vcatpvf(sv, pat, &args);
6755 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6759 va_start(args, pat);
6760 sv_vcatpvf_mg(sv, pat, &args);
6766 =for apidoc sv_catpvf
6768 Processes its arguments like C<sprintf> and appends the formatted
6769 output to an SV. If the appended data contains "wide" characters
6770 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6771 and characters >255 formatted with %c), the original SV might get
6772 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6773 C<SvSETMAGIC()> must typically be called after calling this function
6774 to handle 'set' magic.
6779 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6782 va_start(args, pat);
6783 sv_vcatpvf(sv, pat, &args);
6788 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6790 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6794 =for apidoc sv_catpvf_mg
6796 Like C<sv_catpvf>, but also handles 'set' magic.
6802 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6805 va_start(args, pat);
6806 sv_vcatpvf_mg(sv, pat, &args);
6811 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6813 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6818 =for apidoc sv_vsetpvfn
6820 Works like C<vcatpvfn> but copies the text into the SV instead of
6827 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6829 sv_setpvn(sv, "", 0);
6830 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6834 S_expect_number(pTHX_ char** pattern)
6837 switch (**pattern) {
6838 case '1': case '2': case '3':
6839 case '4': case '5': case '6':
6840 case '7': case '8': case '9':
6841 while (isDIGIT(**pattern))
6842 var = var * 10 + (*(*pattern)++ - '0');
6846 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6849 =for apidoc sv_vcatpvfn
6851 Processes its arguments like C<vsprintf> and appends the formatted output
6852 to an SV. Uses an array of SVs if the C style variable argument list is
6853 missing (NULL). When running with taint checks enabled, indicates via
6854 C<maybe_tainted> if results are untrustworthy (often due to the use of
6861 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6868 static char nullstr[] = "(null)";
6871 /* no matter what, this is a string now */
6872 (void)SvPV_force(sv, origlen);
6874 /* special-case "", "%s", and "%_" */
6877 if (patlen == 2 && pat[0] == '%') {
6881 char *s = va_arg(*args, char*);
6882 sv_catpv(sv, s ? s : nullstr);
6884 else if (svix < svmax) {
6885 sv_catsv(sv, *svargs);
6886 if (DO_UTF8(*svargs))
6892 argsv = va_arg(*args, SV*);
6893 sv_catsv(sv, argsv);
6898 /* See comment on '_' below */
6903 patend = (char*)pat + patlen;
6904 for (p = (char*)pat; p < patend; p = q) {
6907 bool vectorize = FALSE;
6908 bool vectorarg = FALSE;
6909 bool vec_utf = FALSE;
6915 bool has_precis = FALSE;
6917 bool is_utf = FALSE;
6920 U8 utf8buf[UTF8_MAXLEN+1];
6921 STRLEN esignlen = 0;
6923 char *eptr = Nullch;
6925 /* Times 4: a decimal digit takes more than 3 binary digits.
6926 * NV_DIG: mantissa takes than many decimal digits.
6927 * Plus 32: Playing safe. */
6928 char ebuf[IV_DIG * 4 + NV_DIG + 32];
6929 /* large enough for "%#.#f" --chip */
6930 /* what about long double NVs? --jhi */
6933 U8 *vecstr = Null(U8*);
6945 STRLEN dotstrlen = 1;
6946 I32 efix = 0; /* explicit format parameter index */
6947 I32 ewix = 0; /* explicit width index */
6948 I32 epix = 0; /* explicit precision index */
6949 I32 evix = 0; /* explicit vector index */
6950 bool asterisk = FALSE;
6952 /* echo everything up to the next format specification */
6953 for (q = p; q < patend && *q != '%'; ++q) ;
6955 sv_catpvn(sv, p, q - p);
6962 We allow format specification elements in this order:
6963 \d+\$ explicit format parameter index
6965 \*?(\d+\$)?v vector with optional (optionally specified) arg
6966 \d+|\*(\d+\$)? width using optional (optionally specified) arg
6967 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
6969 [%bcdefginopsux_DFOUX] format (mandatory)
6971 if (EXPECT_NUMBER(q, width)) {
7012 if (EXPECT_NUMBER(q, ewix))
7021 if ((vectorarg = asterisk)) {
7031 EXPECT_NUMBER(q, width);
7036 vecsv = va_arg(*args, SV*);
7038 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7039 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7040 dotstr = SvPVx(vecsv, dotstrlen);
7045 vecsv = va_arg(*args, SV*);
7046 vecstr = (U8*)SvPVx(vecsv,veclen);
7047 vec_utf = DO_UTF8(vecsv);
7049 else if (efix ? efix <= svmax : svix < svmax) {
7050 vecsv = svargs[efix ? efix-1 : svix++];
7051 vecstr = (U8*)SvPVx(vecsv,veclen);
7052 vec_utf = DO_UTF8(vecsv);
7062 i = va_arg(*args, int);
7064 i = (ewix ? ewix <= svmax : svix < svmax) ?
7065 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7067 width = (i < 0) ? -i : i;
7077 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7080 i = va_arg(*args, int);
7082 i = (ewix ? ewix <= svmax : svix < svmax)
7083 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7084 precis = (i < 0) ? 0 : i;
7089 precis = precis * 10 + (*q++ - '0');
7097 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7108 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7109 if (*(q + 1) == 'l') { /* lld, llf */
7132 argsv = (efix ? efix <= svmax : svix < svmax) ?
7133 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7140 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7142 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7144 eptr = (char*)utf8buf;
7145 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7157 eptr = va_arg(*args, char*);
7159 #ifdef MACOS_TRADITIONAL
7160 /* On MacOS, %#s format is used for Pascal strings */
7165 elen = strlen(eptr);
7168 elen = sizeof nullstr - 1;
7172 eptr = SvPVx(argsv, elen);
7173 if (DO_UTF8(argsv)) {
7174 if (has_precis && precis < elen) {
7176 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7179 if (width) { /* fudge width (can't fudge elen) */
7180 width += elen - sv_len_utf8(argsv);
7189 * The "%_" hack might have to be changed someday,
7190 * if ISO or ANSI decide to use '_' for something.
7191 * So we keep it hidden from users' code.
7195 argsv = va_arg(*args, SV*);
7196 eptr = SvPVx(argsv, elen);
7202 if (has_precis && elen > precis)
7211 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7229 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7239 case 'h': iv = (short)va_arg(*args, int); break;
7240 default: iv = va_arg(*args, int); break;
7241 case 'l': iv = va_arg(*args, long); break;
7242 case 'V': iv = va_arg(*args, IV); break;
7244 case 'q': iv = va_arg(*args, Quad_t); break;
7251 case 'h': iv = (short)iv; break;
7253 case 'l': iv = (long)iv; break;
7256 case 'q': iv = (Quad_t)iv; break;
7263 esignbuf[esignlen++] = plus;
7267 esignbuf[esignlen++] = '-';
7309 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7319 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7320 default: uv = va_arg(*args, unsigned); break;
7321 case 'l': uv = va_arg(*args, unsigned long); break;
7322 case 'V': uv = va_arg(*args, UV); break;
7324 case 'q': uv = va_arg(*args, Quad_t); break;
7331 case 'h': uv = (unsigned short)uv; break;
7333 case 'l': uv = (unsigned long)uv; break;
7336 case 'q': uv = (Quad_t)uv; break;
7342 eptr = ebuf + sizeof ebuf;
7348 p = (char*)((c == 'X')
7349 ? "0123456789ABCDEF" : "0123456789abcdef");
7355 esignbuf[esignlen++] = '0';
7356 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7362 *--eptr = '0' + dig;
7364 if (alt && *eptr != '0')
7370 *--eptr = '0' + dig;
7373 esignbuf[esignlen++] = '0';
7374 esignbuf[esignlen++] = 'b';
7377 default: /* it had better be ten or less */
7378 #if defined(PERL_Y2KWARN)
7379 if (ckWARN(WARN_Y2K)) {
7381 char *s = SvPV(sv,n);
7382 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7383 && (n == 2 || !isDIGIT(s[n-3])))
7385 Perl_warner(aTHX_ WARN_Y2K,
7386 "Possible Y2K bug: %%%c %s",
7387 c, "format string following '19'");
7393 *--eptr = '0' + dig;
7394 } while (uv /= base);
7397 elen = (ebuf + sizeof ebuf) - eptr;
7400 zeros = precis - elen;
7401 else if (precis == 0 && elen == 1 && *eptr == '0')
7406 /* FLOATING POINT */
7409 c = 'f'; /* maybe %F isn't supported here */
7415 /* This is evil, but floating point is even more evil */
7418 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7421 if (c != 'e' && c != 'E') {
7423 (void)Perl_frexp(nv, &i);
7424 if (i == PERL_INT_MIN)
7425 Perl_die(aTHX_ "panic: frexp");
7427 need = BIT_DIGITS(i);
7429 need += has_precis ? precis : 6; /* known default */
7433 need += 20; /* fudge factor */
7434 if (PL_efloatsize < need) {
7435 Safefree(PL_efloatbuf);
7436 PL_efloatsize = need + 20; /* more fudge */
7437 New(906, PL_efloatbuf, PL_efloatsize, char);
7438 PL_efloatbuf[0] = '\0';
7441 eptr = ebuf + sizeof ebuf;
7444 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7446 /* Copy the one or more characters in a long double
7447 * format before the 'base' ([efgEFG]) character to
7448 * the format string. */
7449 static char const prifldbl[] = PERL_PRIfldbl;
7450 char const *p = prifldbl + sizeof(prifldbl) - 3;
7451 while (p >= prifldbl) { *--eptr = *p--; }
7456 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7461 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7473 /* No taint. Otherwise we are in the strange situation
7474 * where printf() taints but print($float) doesn't.
7476 (void)sprintf(PL_efloatbuf, eptr, nv);
7478 eptr = PL_efloatbuf;
7479 elen = strlen(PL_efloatbuf);
7486 i = SvCUR(sv) - origlen;
7489 case 'h': *(va_arg(*args, short*)) = i; break;
7490 default: *(va_arg(*args, int*)) = i; break;
7491 case 'l': *(va_arg(*args, long*)) = i; break;
7492 case 'V': *(va_arg(*args, IV*)) = i; break;
7494 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7499 sv_setuv_mg(argsv, (UV)i);
7500 continue; /* not "break" */
7507 if (!args && ckWARN(WARN_PRINTF) &&
7508 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7509 SV *msg = sv_newmortal();
7510 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7511 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7514 Perl_sv_catpvf(aTHX_ msg,
7515 "\"%%%c\"", c & 0xFF);
7517 Perl_sv_catpvf(aTHX_ msg,
7518 "\"%%\\%03"UVof"\"",
7521 sv_catpv(msg, "end of string");
7522 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7525 /* output mangled stuff ... */
7531 /* ... right here, because formatting flags should not apply */
7532 SvGROW(sv, SvCUR(sv) + elen + 1);
7534 Copy(eptr, p, elen, char);
7537 SvCUR(sv) = p - SvPVX(sv);
7538 continue; /* not "break" */
7541 have = esignlen + zeros + elen;
7542 need = (have > width ? have : width);
7545 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7547 if (esignlen && fill == '0') {
7548 for (i = 0; i < esignlen; i++)
7552 memset(p, fill, gap);
7555 if (esignlen && fill != '0') {
7556 for (i = 0; i < esignlen; i++)
7560 for (i = zeros; i; i--)
7564 Copy(eptr, p, elen, char);
7568 memset(p, ' ', gap);
7573 Copy(dotstr, p, dotstrlen, char);
7577 vectorize = FALSE; /* done iterating over vecstr */
7582 SvCUR(sv) = p - SvPVX(sv);
7590 #if defined(USE_ITHREADS)
7592 #if defined(USE_THREADS)
7593 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7596 #ifndef GpREFCNT_inc
7597 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7601 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7602 #define av_dup(s) (AV*)sv_dup((SV*)s)
7603 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7604 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7605 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7606 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7607 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7608 #define io_dup(s) (IO*)sv_dup((SV*)s)
7609 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7610 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7611 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7612 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7613 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7616 Perl_re_dup(pTHX_ REGEXP *r)
7618 /* XXX fix when pmop->op_pmregexp becomes shared */
7619 return ReREFCNT_inc(r);
7623 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7627 return (PerlIO*)NULL;
7629 /* look for it in the table first */
7630 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7634 /* create anew and remember what it is */
7635 ret = PerlIO_fdupopen(aTHX_ fp);
7636 ptr_table_store(PL_ptr_table, fp, ret);
7641 Perl_dirp_dup(pTHX_ DIR *dp)
7650 Perl_gp_dup(pTHX_ GP *gp)
7655 /* look for it in the table first */
7656 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7660 /* create anew and remember what it is */
7661 Newz(0, ret, 1, GP);
7662 ptr_table_store(PL_ptr_table, gp, ret);
7665 ret->gp_refcnt = 0; /* must be before any other dups! */
7666 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7667 ret->gp_io = io_dup_inc(gp->gp_io);
7668 ret->gp_form = cv_dup_inc(gp->gp_form);
7669 ret->gp_av = av_dup_inc(gp->gp_av);
7670 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7671 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7672 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7673 ret->gp_cvgen = gp->gp_cvgen;
7674 ret->gp_flags = gp->gp_flags;
7675 ret->gp_line = gp->gp_line;
7676 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7681 Perl_mg_dup(pTHX_ MAGIC *mg)
7683 MAGIC *mgprev = (MAGIC*)NULL;
7686 return (MAGIC*)NULL;
7687 /* look for it in the table first */
7688 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7692 for (; mg; mg = mg->mg_moremagic) {
7694 Newz(0, nmg, 1, MAGIC);
7696 mgprev->mg_moremagic = nmg;
7699 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7700 nmg->mg_private = mg->mg_private;
7701 nmg->mg_type = mg->mg_type;
7702 nmg->mg_flags = mg->mg_flags;
7703 if (mg->mg_type == 'r') {
7704 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7707 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7708 ? sv_dup_inc(mg->mg_obj)
7709 : sv_dup(mg->mg_obj);
7711 nmg->mg_len = mg->mg_len;
7712 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7713 if (mg->mg_ptr && mg->mg_type != 'g') {
7714 if (mg->mg_len >= 0) {
7715 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7716 if (mg->mg_type == 'c' && AMT_AMAGIC((AMT*)mg->mg_ptr)) {
7717 AMT *amtp = (AMT*)mg->mg_ptr;
7718 AMT *namtp = (AMT*)nmg->mg_ptr;
7720 for (i = 1; i < NofAMmeth; i++) {
7721 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7725 else if (mg->mg_len == HEf_SVKEY)
7726 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7734 Perl_ptr_table_new(pTHX)
7737 Newz(0, tbl, 1, PTR_TBL_t);
7740 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7745 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7747 PTR_TBL_ENT_t *tblent;
7748 UV hash = PTR2UV(sv);
7750 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7751 for (; tblent; tblent = tblent->next) {
7752 if (tblent->oldval == sv)
7753 return tblent->newval;
7759 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7761 PTR_TBL_ENT_t *tblent, **otblent;
7762 /* XXX this may be pessimal on platforms where pointers aren't good
7763 * hash values e.g. if they grow faster in the most significant
7765 UV hash = PTR2UV(oldv);
7769 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7770 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7771 if (tblent->oldval == oldv) {
7772 tblent->newval = newv;
7777 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7778 tblent->oldval = oldv;
7779 tblent->newval = newv;
7780 tblent->next = *otblent;
7783 if (i && tbl->tbl_items > tbl->tbl_max)
7784 ptr_table_split(tbl);
7788 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7790 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7791 UV oldsize = tbl->tbl_max + 1;
7792 UV newsize = oldsize * 2;
7795 Renew(ary, newsize, PTR_TBL_ENT_t*);
7796 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7797 tbl->tbl_max = --newsize;
7799 for (i=0; i < oldsize; i++, ary++) {
7800 PTR_TBL_ENT_t **curentp, **entp, *ent;
7803 curentp = ary + oldsize;
7804 for (entp = ary, ent = *ary; ent; ent = *entp) {
7805 if ((newsize & PTR2UV(ent->oldval)) != i) {
7807 ent->next = *curentp;
7818 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7820 register PTR_TBL_ENT_t **array;
7821 register PTR_TBL_ENT_t *entry;
7822 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7826 if (!tbl || !tbl->tbl_items) {
7830 array = tbl->tbl_ary;
7837 entry = entry->next;
7841 if (++riter > max) {
7844 entry = array[riter];
7852 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7857 ptr_table_clear(tbl);
7858 Safefree(tbl->tbl_ary);
7867 S_gv_share(pTHX_ SV *sstr)
7870 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
7872 if (GvIO(gv) || GvFORM(gv)) {
7873 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
7875 else if (!GvCV(gv)) {
7879 /* CvPADLISTs cannot be shared */
7880 if (!CvXSUB(GvCV(gv))) {
7885 if (!GvSHARED(gv)) {
7887 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
7888 HvNAME(GvSTASH(gv)), GvNAME(gv));
7894 * write attempts will die with
7895 * "Modification of a read-only value attempted"
7901 SvREADONLY_on(GvSV(gv));
7908 SvREADONLY_on(GvAV(gv));
7915 SvREADONLY_on(GvAV(gv));
7918 return sstr; /* he_dup() will SvREFCNT_inc() */
7922 Perl_sv_dup(pTHX_ SV *sstr)
7926 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
7928 /* look for it in the table first */
7929 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
7933 /* create anew and remember what it is */
7935 ptr_table_store(PL_ptr_table, sstr, dstr);
7938 SvFLAGS(dstr) = SvFLAGS(sstr);
7939 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
7940 SvREFCNT(dstr) = 0; /* must be before any other dups! */
7943 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
7944 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
7945 PL_watch_pvx, SvPVX(sstr));
7948 switch (SvTYPE(sstr)) {
7953 SvANY(dstr) = new_XIV();
7954 SvIVX(dstr) = SvIVX(sstr);
7957 SvANY(dstr) = new_XNV();
7958 SvNVX(dstr) = SvNVX(sstr);
7961 SvANY(dstr) = new_XRV();
7962 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7965 SvANY(dstr) = new_XPV();
7966 SvCUR(dstr) = SvCUR(sstr);
7967 SvLEN(dstr) = SvLEN(sstr);
7969 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7970 else if (SvPVX(sstr) && SvLEN(sstr))
7971 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7973 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7976 SvANY(dstr) = new_XPVIV();
7977 SvCUR(dstr) = SvCUR(sstr);
7978 SvLEN(dstr) = SvLEN(sstr);
7979 SvIVX(dstr) = SvIVX(sstr);
7981 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7982 else if (SvPVX(sstr) && SvLEN(sstr))
7983 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7985 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
7988 SvANY(dstr) = new_XPVNV();
7989 SvCUR(dstr) = SvCUR(sstr);
7990 SvLEN(dstr) = SvLEN(sstr);
7991 SvIVX(dstr) = SvIVX(sstr);
7992 SvNVX(dstr) = SvNVX(sstr);
7994 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
7995 else if (SvPVX(sstr) && SvLEN(sstr))
7996 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
7998 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8001 SvANY(dstr) = new_XPVMG();
8002 SvCUR(dstr) = SvCUR(sstr);
8003 SvLEN(dstr) = SvLEN(sstr);
8004 SvIVX(dstr) = SvIVX(sstr);
8005 SvNVX(dstr) = SvNVX(sstr);
8006 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8007 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8009 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8010 else if (SvPVX(sstr) && SvLEN(sstr))
8011 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8013 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8016 SvANY(dstr) = new_XPVBM();
8017 SvCUR(dstr) = SvCUR(sstr);
8018 SvLEN(dstr) = SvLEN(sstr);
8019 SvIVX(dstr) = SvIVX(sstr);
8020 SvNVX(dstr) = SvNVX(sstr);
8021 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8022 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8024 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8025 else if (SvPVX(sstr) && SvLEN(sstr))
8026 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8028 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8029 BmRARE(dstr) = BmRARE(sstr);
8030 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8031 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8034 SvANY(dstr) = new_XPVLV();
8035 SvCUR(dstr) = SvCUR(sstr);
8036 SvLEN(dstr) = SvLEN(sstr);
8037 SvIVX(dstr) = SvIVX(sstr);
8038 SvNVX(dstr) = SvNVX(sstr);
8039 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8040 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8042 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8043 else if (SvPVX(sstr) && SvLEN(sstr))
8044 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8046 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8047 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8048 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8049 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8050 LvTYPE(dstr) = LvTYPE(sstr);
8053 if (GvSHARED((GV*)sstr)) {
8055 if ((share = gv_share(sstr))) {
8059 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8060 HvNAME(GvSTASH(share)), GvNAME(share));
8065 SvANY(dstr) = new_XPVGV();
8066 SvCUR(dstr) = SvCUR(sstr);
8067 SvLEN(dstr) = SvLEN(sstr);
8068 SvIVX(dstr) = SvIVX(sstr);
8069 SvNVX(dstr) = SvNVX(sstr);
8070 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8071 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8073 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8074 else if (SvPVX(sstr) && SvLEN(sstr))
8075 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8077 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8078 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8079 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8080 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8081 GvFLAGS(dstr) = GvFLAGS(sstr);
8082 GvGP(dstr) = gp_dup(GvGP(sstr));
8083 (void)GpREFCNT_inc(GvGP(dstr));
8086 SvANY(dstr) = new_XPVIO();
8087 SvCUR(dstr) = SvCUR(sstr);
8088 SvLEN(dstr) = SvLEN(sstr);
8089 SvIVX(dstr) = SvIVX(sstr);
8090 SvNVX(dstr) = SvNVX(sstr);
8091 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8092 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8094 SvRV(dstr) = sv_dup_inc(SvRV(sstr));
8095 else if (SvPVX(sstr) && SvLEN(sstr))
8096 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8098 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8099 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8100 if (IoOFP(sstr) == IoIFP(sstr))
8101 IoOFP(dstr) = IoIFP(dstr);
8103 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8104 /* PL_rsfp_filters entries have fake IoDIRP() */
8105 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8106 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8108 IoDIRP(dstr) = IoDIRP(sstr);
8109 IoLINES(dstr) = IoLINES(sstr);
8110 IoPAGE(dstr) = IoPAGE(sstr);
8111 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8112 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8113 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8114 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8115 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8116 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8117 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8118 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8119 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8120 IoTYPE(dstr) = IoTYPE(sstr);
8121 IoFLAGS(dstr) = IoFLAGS(sstr);
8124 SvANY(dstr) = new_XPVAV();
8125 SvCUR(dstr) = SvCUR(sstr);
8126 SvLEN(dstr) = SvLEN(sstr);
8127 SvIVX(dstr) = SvIVX(sstr);
8128 SvNVX(dstr) = SvNVX(sstr);
8129 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8130 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8131 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8132 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8133 if (AvARRAY((AV*)sstr)) {
8134 SV **dst_ary, **src_ary;
8135 SSize_t items = AvFILLp((AV*)sstr) + 1;
8137 src_ary = AvARRAY((AV*)sstr);
8138 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8139 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8140 SvPVX(dstr) = (char*)dst_ary;
8141 AvALLOC((AV*)dstr) = dst_ary;
8142 if (AvREAL((AV*)sstr)) {
8144 *dst_ary++ = sv_dup_inc(*src_ary++);
8148 *dst_ary++ = sv_dup(*src_ary++);
8150 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8151 while (items-- > 0) {
8152 *dst_ary++ = &PL_sv_undef;
8156 SvPVX(dstr) = Nullch;
8157 AvALLOC((AV*)dstr) = (SV**)NULL;
8161 SvANY(dstr) = new_XPVHV();
8162 SvCUR(dstr) = SvCUR(sstr);
8163 SvLEN(dstr) = SvLEN(sstr);
8164 SvIVX(dstr) = SvIVX(sstr);
8165 SvNVX(dstr) = SvNVX(sstr);
8166 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8167 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8168 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8169 if (HvARRAY((HV*)sstr)) {
8171 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8172 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8173 Newz(0, dxhv->xhv_array,
8174 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8175 while (i <= sxhv->xhv_max) {
8176 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8177 !!HvSHAREKEYS(sstr));
8180 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8183 SvPVX(dstr) = Nullch;
8184 HvEITER((HV*)dstr) = (HE*)NULL;
8186 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8187 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8190 SvANY(dstr) = new_XPVFM();
8191 FmLINES(dstr) = FmLINES(sstr);
8195 SvANY(dstr) = new_XPVCV();
8197 SvCUR(dstr) = SvCUR(sstr);
8198 SvLEN(dstr) = SvLEN(sstr);
8199 SvIVX(dstr) = SvIVX(sstr);
8200 SvNVX(dstr) = SvNVX(sstr);
8201 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8202 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8203 if (SvPVX(sstr) && SvLEN(sstr))
8204 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8206 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8207 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8208 CvSTART(dstr) = CvSTART(sstr);
8209 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8210 CvXSUB(dstr) = CvXSUB(sstr);
8211 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8212 CvGV(dstr) = gv_dup(CvGV(sstr));
8213 CvDEPTH(dstr) = CvDEPTH(sstr);
8214 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8215 /* XXX padlists are real, but pretend to be not */
8216 AvREAL_on(CvPADLIST(sstr));
8217 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8218 AvREAL_off(CvPADLIST(sstr));
8219 AvREAL_off(CvPADLIST(dstr));
8222 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8223 if (!CvANON(sstr) || CvCLONED(sstr))
8224 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8226 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8227 CvFLAGS(dstr) = CvFLAGS(sstr);
8230 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8234 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8241 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8246 return (PERL_CONTEXT*)NULL;
8248 /* look for it in the table first */
8249 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8253 /* create anew and remember what it is */
8254 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8255 ptr_table_store(PL_ptr_table, cxs, ncxs);
8258 PERL_CONTEXT *cx = &cxs[ix];
8259 PERL_CONTEXT *ncx = &ncxs[ix];
8260 ncx->cx_type = cx->cx_type;
8261 if (CxTYPE(cx) == CXt_SUBST) {
8262 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8265 ncx->blk_oldsp = cx->blk_oldsp;
8266 ncx->blk_oldcop = cx->blk_oldcop;
8267 ncx->blk_oldretsp = cx->blk_oldretsp;
8268 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8269 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8270 ncx->blk_oldpm = cx->blk_oldpm;
8271 ncx->blk_gimme = cx->blk_gimme;
8272 switch (CxTYPE(cx)) {
8274 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8275 ? cv_dup_inc(cx->blk_sub.cv)
8276 : cv_dup(cx->blk_sub.cv));
8277 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8278 ? av_dup_inc(cx->blk_sub.argarray)
8280 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8281 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8282 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8283 ncx->blk_sub.lval = cx->blk_sub.lval;
8286 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8287 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8288 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8289 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8290 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8293 ncx->blk_loop.label = cx->blk_loop.label;
8294 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8295 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8296 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8297 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8298 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8299 ? cx->blk_loop.iterdata
8300 : gv_dup((GV*)cx->blk_loop.iterdata));
8301 ncx->blk_loop.oldcurpad
8302 = (SV**)ptr_table_fetch(PL_ptr_table,
8303 cx->blk_loop.oldcurpad);
8304 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8305 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8306 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8307 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8308 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8311 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8312 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8313 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8314 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8327 Perl_si_dup(pTHX_ PERL_SI *si)
8332 return (PERL_SI*)NULL;
8334 /* look for it in the table first */
8335 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8339 /* create anew and remember what it is */
8340 Newz(56, nsi, 1, PERL_SI);
8341 ptr_table_store(PL_ptr_table, si, nsi);
8343 nsi->si_stack = av_dup_inc(si->si_stack);
8344 nsi->si_cxix = si->si_cxix;
8345 nsi->si_cxmax = si->si_cxmax;
8346 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8347 nsi->si_type = si->si_type;
8348 nsi->si_prev = si_dup(si->si_prev);
8349 nsi->si_next = si_dup(si->si_next);
8350 nsi->si_markoff = si->si_markoff;
8355 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8356 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8357 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8358 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8359 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8360 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8361 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8362 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8363 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8364 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8365 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8366 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8369 #define pv_dup_inc(p) SAVEPV(p)
8370 #define pv_dup(p) SAVEPV(p)
8371 #define svp_dup_inc(p,pp) any_dup(p,pp)
8374 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8381 /* look for it in the table first */
8382 ret = ptr_table_fetch(PL_ptr_table, v);
8386 /* see if it is part of the interpreter structure */
8387 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8388 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8396 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8398 ANY *ss = proto_perl->Tsavestack;
8399 I32 ix = proto_perl->Tsavestack_ix;
8400 I32 max = proto_perl->Tsavestack_max;
8413 void (*dptr) (void*);
8414 void (*dxptr) (pTHXo_ void*);
8417 Newz(54, nss, max, ANY);
8423 case SAVEt_ITEM: /* normal string */
8424 sv = (SV*)POPPTR(ss,ix);
8425 TOPPTR(nss,ix) = sv_dup_inc(sv);
8426 sv = (SV*)POPPTR(ss,ix);
8427 TOPPTR(nss,ix) = sv_dup_inc(sv);
8429 case SAVEt_SV: /* scalar reference */
8430 sv = (SV*)POPPTR(ss,ix);
8431 TOPPTR(nss,ix) = sv_dup_inc(sv);
8432 gv = (GV*)POPPTR(ss,ix);
8433 TOPPTR(nss,ix) = gv_dup_inc(gv);
8435 case SAVEt_GENERIC_PVREF: /* generic char* */
8436 c = (char*)POPPTR(ss,ix);
8437 TOPPTR(nss,ix) = pv_dup(c);
8438 ptr = POPPTR(ss,ix);
8439 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8441 case SAVEt_GENERIC_SVREF: /* generic sv */
8442 case SAVEt_SVREF: /* scalar reference */
8443 sv = (SV*)POPPTR(ss,ix);
8444 TOPPTR(nss,ix) = sv_dup_inc(sv);
8445 ptr = POPPTR(ss,ix);
8446 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8448 case SAVEt_AV: /* array reference */
8449 av = (AV*)POPPTR(ss,ix);
8450 TOPPTR(nss,ix) = av_dup_inc(av);
8451 gv = (GV*)POPPTR(ss,ix);
8452 TOPPTR(nss,ix) = gv_dup(gv);
8454 case SAVEt_HV: /* hash reference */
8455 hv = (HV*)POPPTR(ss,ix);
8456 TOPPTR(nss,ix) = hv_dup_inc(hv);
8457 gv = (GV*)POPPTR(ss,ix);
8458 TOPPTR(nss,ix) = gv_dup(gv);
8460 case SAVEt_INT: /* int reference */
8461 ptr = POPPTR(ss,ix);
8462 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8463 intval = (int)POPINT(ss,ix);
8464 TOPINT(nss,ix) = intval;
8466 case SAVEt_LONG: /* long reference */
8467 ptr = POPPTR(ss,ix);
8468 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8469 longval = (long)POPLONG(ss,ix);
8470 TOPLONG(nss,ix) = longval;
8472 case SAVEt_I32: /* I32 reference */
8473 case SAVEt_I16: /* I16 reference */
8474 case SAVEt_I8: /* I8 reference */
8475 ptr = POPPTR(ss,ix);
8476 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8480 case SAVEt_IV: /* IV reference */
8481 ptr = POPPTR(ss,ix);
8482 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8486 case SAVEt_SPTR: /* SV* reference */
8487 ptr = POPPTR(ss,ix);
8488 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8489 sv = (SV*)POPPTR(ss,ix);
8490 TOPPTR(nss,ix) = sv_dup(sv);
8492 case SAVEt_VPTR: /* random* reference */
8493 ptr = POPPTR(ss,ix);
8494 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8495 ptr = POPPTR(ss,ix);
8496 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8498 case SAVEt_PPTR: /* char* reference */
8499 ptr = POPPTR(ss,ix);
8500 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8501 c = (char*)POPPTR(ss,ix);
8502 TOPPTR(nss,ix) = pv_dup(c);
8504 case SAVEt_HPTR: /* HV* reference */
8505 ptr = POPPTR(ss,ix);
8506 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8507 hv = (HV*)POPPTR(ss,ix);
8508 TOPPTR(nss,ix) = hv_dup(hv);
8510 case SAVEt_APTR: /* AV* reference */
8511 ptr = POPPTR(ss,ix);
8512 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8513 av = (AV*)POPPTR(ss,ix);
8514 TOPPTR(nss,ix) = av_dup(av);
8517 gv = (GV*)POPPTR(ss,ix);
8518 TOPPTR(nss,ix) = gv_dup(gv);
8520 case SAVEt_GP: /* scalar reference */
8521 gp = (GP*)POPPTR(ss,ix);
8522 TOPPTR(nss,ix) = gp = gp_dup(gp);
8523 (void)GpREFCNT_inc(gp);
8524 gv = (GV*)POPPTR(ss,ix);
8525 TOPPTR(nss,ix) = gv_dup_inc(c);
8526 c = (char*)POPPTR(ss,ix);
8527 TOPPTR(nss,ix) = pv_dup(c);
8534 case SAVEt_MORTALIZESV:
8535 sv = (SV*)POPPTR(ss,ix);
8536 TOPPTR(nss,ix) = sv_dup_inc(sv);
8539 ptr = POPPTR(ss,ix);
8540 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8541 /* these are assumed to be refcounted properly */
8542 switch (((OP*)ptr)->op_type) {
8549 TOPPTR(nss,ix) = ptr;
8554 TOPPTR(nss,ix) = Nullop;
8559 TOPPTR(nss,ix) = Nullop;
8562 c = (char*)POPPTR(ss,ix);
8563 TOPPTR(nss,ix) = pv_dup_inc(c);
8566 longval = POPLONG(ss,ix);
8567 TOPLONG(nss,ix) = longval;
8570 hv = (HV*)POPPTR(ss,ix);
8571 TOPPTR(nss,ix) = hv_dup_inc(hv);
8572 c = (char*)POPPTR(ss,ix);
8573 TOPPTR(nss,ix) = pv_dup_inc(c);
8577 case SAVEt_DESTRUCTOR:
8578 ptr = POPPTR(ss,ix);
8579 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8580 dptr = POPDPTR(ss,ix);
8581 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8583 case SAVEt_DESTRUCTOR_X:
8584 ptr = POPPTR(ss,ix);
8585 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8586 dxptr = POPDXPTR(ss,ix);
8587 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8589 case SAVEt_REGCONTEXT:
8595 case SAVEt_STACK_POS: /* Position on Perl stack */
8599 case SAVEt_AELEM: /* array element */
8600 sv = (SV*)POPPTR(ss,ix);
8601 TOPPTR(nss,ix) = sv_dup_inc(sv);
8604 av = (AV*)POPPTR(ss,ix);
8605 TOPPTR(nss,ix) = av_dup_inc(av);
8607 case SAVEt_HELEM: /* hash element */
8608 sv = (SV*)POPPTR(ss,ix);
8609 TOPPTR(nss,ix) = sv_dup_inc(sv);
8610 sv = (SV*)POPPTR(ss,ix);
8611 TOPPTR(nss,ix) = sv_dup_inc(sv);
8612 hv = (HV*)POPPTR(ss,ix);
8613 TOPPTR(nss,ix) = hv_dup_inc(hv);
8616 ptr = POPPTR(ss,ix);
8617 TOPPTR(nss,ix) = ptr;
8624 av = (AV*)POPPTR(ss,ix);
8625 TOPPTR(nss,ix) = av_dup(av);
8628 longval = (long)POPLONG(ss,ix);
8629 TOPLONG(nss,ix) = longval;
8630 ptr = POPPTR(ss,ix);
8631 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8632 sv = (SV*)POPPTR(ss,ix);
8633 TOPPTR(nss,ix) = sv_dup(sv);
8636 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8648 perl_clone(PerlInterpreter *proto_perl, UV flags)
8651 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8654 #ifdef PERL_IMPLICIT_SYS
8655 return perl_clone_using(proto_perl, flags,
8657 proto_perl->IMemShared,
8658 proto_perl->IMemParse,
8668 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8669 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8670 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8671 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8672 struct IPerlDir* ipD, struct IPerlSock* ipS,
8673 struct IPerlProc* ipP)
8675 /* XXX many of the string copies here can be optimized if they're
8676 * constants; they need to be allocated as common memory and just
8677 * their pointers copied. */
8681 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8683 PERL_SET_THX(pPerl);
8684 # else /* !PERL_OBJECT */
8685 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8686 PERL_SET_THX(my_perl);
8689 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8695 # else /* !DEBUGGING */
8696 Zero(my_perl, 1, PerlInterpreter);
8697 # endif /* DEBUGGING */
8701 PL_MemShared = ipMS;
8709 # endif /* PERL_OBJECT */
8710 #else /* !PERL_IMPLICIT_SYS */
8712 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8713 PERL_SET_THX(my_perl);
8716 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8722 # else /* !DEBUGGING */
8723 Zero(my_perl, 1, PerlInterpreter);
8724 # endif /* DEBUGGING */
8725 #endif /* PERL_IMPLICIT_SYS */
8728 PL_xiv_arenaroot = NULL;
8730 PL_xnv_arenaroot = NULL;
8732 PL_xrv_arenaroot = NULL;
8734 PL_xpv_arenaroot = NULL;
8736 PL_xpviv_arenaroot = NULL;
8737 PL_xpviv_root = NULL;
8738 PL_xpvnv_arenaroot = NULL;
8739 PL_xpvnv_root = NULL;
8740 PL_xpvcv_arenaroot = NULL;
8741 PL_xpvcv_root = NULL;
8742 PL_xpvav_arenaroot = NULL;
8743 PL_xpvav_root = NULL;
8744 PL_xpvhv_arenaroot = NULL;
8745 PL_xpvhv_root = NULL;
8746 PL_xpvmg_arenaroot = NULL;
8747 PL_xpvmg_root = NULL;
8748 PL_xpvlv_arenaroot = NULL;
8749 PL_xpvlv_root = NULL;
8750 PL_xpvbm_arenaroot = NULL;
8751 PL_xpvbm_root = NULL;
8752 PL_he_arenaroot = NULL;
8754 PL_nice_chunk = NULL;
8755 PL_nice_chunk_size = 0;
8758 PL_sv_root = Nullsv;
8759 PL_sv_arenaroot = Nullsv;
8761 PL_debug = proto_perl->Idebug;
8763 /* create SV map for pointer relocation */
8764 PL_ptr_table = ptr_table_new();
8766 /* initialize these special pointers as early as possible */
8767 SvANY(&PL_sv_undef) = NULL;
8768 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8769 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8770 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8773 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8775 SvANY(&PL_sv_no) = new_XPVNV();
8777 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8778 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8779 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8780 SvCUR(&PL_sv_no) = 0;
8781 SvLEN(&PL_sv_no) = 1;
8782 SvNVX(&PL_sv_no) = 0;
8783 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8786 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8788 SvANY(&PL_sv_yes) = new_XPVNV();
8790 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8791 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8792 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8793 SvCUR(&PL_sv_yes) = 1;
8794 SvLEN(&PL_sv_yes) = 2;
8795 SvNVX(&PL_sv_yes) = 1;
8796 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8798 /* create shared string table */
8799 PL_strtab = newHV();
8800 HvSHAREKEYS_off(PL_strtab);
8801 hv_ksplit(PL_strtab, 512);
8802 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8804 PL_compiling = proto_perl->Icompiling;
8805 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8806 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8807 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8808 if (!specialWARN(PL_compiling.cop_warnings))
8809 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8810 if (!specialCopIO(PL_compiling.cop_io))
8811 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8812 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8814 /* pseudo environmental stuff */
8815 PL_origargc = proto_perl->Iorigargc;
8817 New(0, PL_origargv, i+1, char*);
8818 PL_origargv[i] = '\0';
8820 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8822 PL_envgv = gv_dup(proto_perl->Ienvgv);
8823 PL_incgv = gv_dup(proto_perl->Iincgv);
8824 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8825 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8826 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8827 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8830 PL_minus_c = proto_perl->Iminus_c;
8831 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8832 PL_localpatches = proto_perl->Ilocalpatches;
8833 PL_splitstr = proto_perl->Isplitstr;
8834 PL_preprocess = proto_perl->Ipreprocess;
8835 PL_minus_n = proto_perl->Iminus_n;
8836 PL_minus_p = proto_perl->Iminus_p;
8837 PL_minus_l = proto_perl->Iminus_l;
8838 PL_minus_a = proto_perl->Iminus_a;
8839 PL_minus_F = proto_perl->Iminus_F;
8840 PL_doswitches = proto_perl->Idoswitches;
8841 PL_dowarn = proto_perl->Idowarn;
8842 PL_doextract = proto_perl->Idoextract;
8843 PL_sawampersand = proto_perl->Isawampersand;
8844 PL_unsafe = proto_perl->Iunsafe;
8845 PL_inplace = SAVEPV(proto_perl->Iinplace);
8846 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8847 PL_perldb = proto_perl->Iperldb;
8848 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
8850 /* magical thingies */
8851 /* XXX time(&PL_basetime) when asked for? */
8852 PL_basetime = proto_perl->Ibasetime;
8853 PL_formfeed = sv_dup(proto_perl->Iformfeed);
8855 PL_maxsysfd = proto_perl->Imaxsysfd;
8856 PL_multiline = proto_perl->Imultiline;
8857 PL_statusvalue = proto_perl->Istatusvalue;
8859 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
8862 /* shortcuts to various I/O objects */
8863 PL_stdingv = gv_dup(proto_perl->Istdingv);
8864 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
8865 PL_defgv = gv_dup(proto_perl->Idefgv);
8866 PL_argvgv = gv_dup(proto_perl->Iargvgv);
8867 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
8868 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
8870 /* shortcuts to regexp stuff */
8871 PL_replgv = gv_dup(proto_perl->Ireplgv);
8873 /* shortcuts to misc objects */
8874 PL_errgv = gv_dup(proto_perl->Ierrgv);
8876 /* shortcuts to debugging objects */
8877 PL_DBgv = gv_dup(proto_perl->IDBgv);
8878 PL_DBline = gv_dup(proto_perl->IDBline);
8879 PL_DBsub = gv_dup(proto_perl->IDBsub);
8880 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
8881 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
8882 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
8883 PL_lineary = av_dup(proto_perl->Ilineary);
8884 PL_dbargs = av_dup(proto_perl->Idbargs);
8887 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
8888 PL_curstash = hv_dup(proto_perl->Tcurstash);
8889 PL_debstash = hv_dup(proto_perl->Idebstash);
8890 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
8891 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
8893 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
8894 PL_endav = av_dup_inc(proto_perl->Iendav);
8895 PL_checkav = av_dup_inc(proto_perl->Icheckav);
8896 PL_initav = av_dup_inc(proto_perl->Iinitav);
8898 PL_sub_generation = proto_perl->Isub_generation;
8900 /* funky return mechanisms */
8901 PL_forkprocess = proto_perl->Iforkprocess;
8903 /* subprocess state */
8904 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
8906 /* internal state */
8907 PL_tainting = proto_perl->Itainting;
8908 PL_maxo = proto_perl->Imaxo;
8909 if (proto_perl->Iop_mask)
8910 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
8912 PL_op_mask = Nullch;
8914 /* current interpreter roots */
8915 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
8916 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
8917 PL_main_start = proto_perl->Imain_start;
8918 PL_eval_root = proto_perl->Ieval_root;
8919 PL_eval_start = proto_perl->Ieval_start;
8921 /* runtime control stuff */
8922 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
8923 PL_copline = proto_perl->Icopline;
8925 PL_filemode = proto_perl->Ifilemode;
8926 PL_lastfd = proto_perl->Ilastfd;
8927 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
8930 PL_gensym = proto_perl->Igensym;
8931 PL_preambled = proto_perl->Ipreambled;
8932 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
8933 PL_laststatval = proto_perl->Ilaststatval;
8934 PL_laststype = proto_perl->Ilaststype;
8935 PL_mess_sv = Nullsv;
8937 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
8938 PL_ofmt = SAVEPV(proto_perl->Iofmt);
8940 /* interpreter atexit processing */
8941 PL_exitlistlen = proto_perl->Iexitlistlen;
8942 if (PL_exitlistlen) {
8943 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8944 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
8947 PL_exitlist = (PerlExitListEntry*)NULL;
8948 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
8950 PL_profiledata = NULL;
8951 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
8952 /* PL_rsfp_filters entries have fake IoDIRP() */
8953 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
8955 PL_compcv = cv_dup(proto_perl->Icompcv);
8956 PL_comppad = av_dup(proto_perl->Icomppad);
8957 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
8958 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
8959 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
8960 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
8961 proto_perl->Tcurpad);
8963 #ifdef HAVE_INTERP_INTERN
8964 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
8967 /* more statics moved here */
8968 PL_generation = proto_perl->Igeneration;
8969 PL_DBcv = cv_dup(proto_perl->IDBcv);
8971 PL_in_clean_objs = proto_perl->Iin_clean_objs;
8972 PL_in_clean_all = proto_perl->Iin_clean_all;
8974 PL_uid = proto_perl->Iuid;
8975 PL_euid = proto_perl->Ieuid;
8976 PL_gid = proto_perl->Igid;
8977 PL_egid = proto_perl->Iegid;
8978 PL_nomemok = proto_perl->Inomemok;
8979 PL_an = proto_perl->Ian;
8980 PL_cop_seqmax = proto_perl->Icop_seqmax;
8981 PL_op_seqmax = proto_perl->Iop_seqmax;
8982 PL_evalseq = proto_perl->Ievalseq;
8983 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
8984 PL_origalen = proto_perl->Iorigalen;
8985 PL_pidstatus = newHV(); /* XXX flag for cloning? */
8986 PL_osname = SAVEPV(proto_perl->Iosname);
8987 PL_sh_path = SAVEPV(proto_perl->Ish_path);
8988 PL_sighandlerp = proto_perl->Isighandlerp;
8991 PL_runops = proto_perl->Irunops;
8993 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
8996 PL_cshlen = proto_perl->Icshlen;
8997 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9000 PL_lex_state = proto_perl->Ilex_state;
9001 PL_lex_defer = proto_perl->Ilex_defer;
9002 PL_lex_expect = proto_perl->Ilex_expect;
9003 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9004 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9005 PL_lex_starts = proto_perl->Ilex_starts;
9006 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
9007 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
9008 PL_lex_op = proto_perl->Ilex_op;
9009 PL_lex_inpat = proto_perl->Ilex_inpat;
9010 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9011 PL_lex_brackets = proto_perl->Ilex_brackets;
9012 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9013 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9014 PL_lex_casemods = proto_perl->Ilex_casemods;
9015 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9016 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9018 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9019 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9020 PL_nexttoke = proto_perl->Inexttoke;
9022 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9023 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9024 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9025 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9026 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9027 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9028 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9029 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9030 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9031 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9032 PL_pending_ident = proto_perl->Ipending_ident;
9033 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9035 PL_expect = proto_perl->Iexpect;
9037 PL_multi_start = proto_perl->Imulti_start;
9038 PL_multi_end = proto_perl->Imulti_end;
9039 PL_multi_open = proto_perl->Imulti_open;
9040 PL_multi_close = proto_perl->Imulti_close;
9042 PL_error_count = proto_perl->Ierror_count;
9043 PL_subline = proto_perl->Isubline;
9044 PL_subname = sv_dup_inc(proto_perl->Isubname);
9046 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9047 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9048 PL_padix = proto_perl->Ipadix;
9049 PL_padix_floor = proto_perl->Ipadix_floor;
9050 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9052 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9053 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9054 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9055 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9056 PL_last_lop_op = proto_perl->Ilast_lop_op;
9057 PL_in_my = proto_perl->Iin_my;
9058 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9060 PL_cryptseen = proto_perl->Icryptseen;
9063 PL_hints = proto_perl->Ihints;
9065 PL_amagic_generation = proto_perl->Iamagic_generation;
9067 #ifdef USE_LOCALE_COLLATE
9068 PL_collation_ix = proto_perl->Icollation_ix;
9069 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9070 PL_collation_standard = proto_perl->Icollation_standard;
9071 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9072 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9073 #endif /* USE_LOCALE_COLLATE */
9075 #ifdef USE_LOCALE_NUMERIC
9076 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9077 PL_numeric_standard = proto_perl->Inumeric_standard;
9078 PL_numeric_local = proto_perl->Inumeric_local;
9079 PL_numeric_radix = sv_dup_inc(proto_perl->Inumeric_radix);
9080 #endif /* !USE_LOCALE_NUMERIC */
9082 /* utf8 character classes */
9083 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9084 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9085 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9086 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9087 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9088 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9089 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9090 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9091 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9092 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9093 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9094 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9095 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9096 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9097 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9098 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9099 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9102 PL_last_swash_hv = Nullhv; /* reinits on demand */
9103 PL_last_swash_klen = 0;
9104 PL_last_swash_key[0]= '\0';
9105 PL_last_swash_tmps = (U8*)NULL;
9106 PL_last_swash_slen = 0;
9108 /* perly.c globals */
9109 PL_yydebug = proto_perl->Iyydebug;
9110 PL_yynerrs = proto_perl->Iyynerrs;
9111 PL_yyerrflag = proto_perl->Iyyerrflag;
9112 PL_yychar = proto_perl->Iyychar;
9113 PL_yyval = proto_perl->Iyyval;
9114 PL_yylval = proto_perl->Iyylval;
9116 PL_glob_index = proto_perl->Iglob_index;
9117 PL_srand_called = proto_perl->Isrand_called;
9118 PL_uudmap['M'] = 0; /* reinits on demand */
9119 PL_bitcount = Nullch; /* reinits on demand */
9121 if (proto_perl->Ipsig_pend) {
9122 Newz(0, PL_psig_pend, SIG_SIZE, int);
9125 PL_psig_pend = (int*)NULL;
9128 if (proto_perl->Ipsig_ptr) {
9129 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9130 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9131 for (i = 1; i < SIG_SIZE; i++) {
9132 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9133 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9137 PL_psig_ptr = (SV**)NULL;
9138 PL_psig_name = (SV**)NULL;
9141 /* thrdvar.h stuff */
9143 if (flags & CLONEf_COPY_STACKS) {
9144 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9145 PL_tmps_ix = proto_perl->Ttmps_ix;
9146 PL_tmps_max = proto_perl->Ttmps_max;
9147 PL_tmps_floor = proto_perl->Ttmps_floor;
9148 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9150 while (i <= PL_tmps_ix) {
9151 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9155 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9156 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9157 Newz(54, PL_markstack, i, I32);
9158 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9159 - proto_perl->Tmarkstack);
9160 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9161 - proto_perl->Tmarkstack);
9162 Copy(proto_perl->Tmarkstack, PL_markstack,
9163 PL_markstack_ptr - PL_markstack + 1, I32);
9165 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9166 * NOTE: unlike the others! */
9167 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9168 PL_scopestack_max = proto_perl->Tscopestack_max;
9169 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9170 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9172 /* next push_return() sets PL_retstack[PL_retstack_ix]
9173 * NOTE: unlike the others! */
9174 PL_retstack_ix = proto_perl->Tretstack_ix;
9175 PL_retstack_max = proto_perl->Tretstack_max;
9176 Newz(54, PL_retstack, PL_retstack_max, OP*);
9177 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9179 /* NOTE: si_dup() looks at PL_markstack */
9180 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9182 /* PL_curstack = PL_curstackinfo->si_stack; */
9183 PL_curstack = av_dup(proto_perl->Tcurstack);
9184 PL_mainstack = av_dup(proto_perl->Tmainstack);
9186 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9187 PL_stack_base = AvARRAY(PL_curstack);
9188 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9189 - proto_perl->Tstack_base);
9190 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9192 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9193 * NOTE: unlike the others! */
9194 PL_savestack_ix = proto_perl->Tsavestack_ix;
9195 PL_savestack_max = proto_perl->Tsavestack_max;
9196 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9197 PL_savestack = ss_dup(proto_perl);
9201 ENTER; /* perl_destruct() wants to LEAVE; */
9204 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9205 PL_top_env = &PL_start_env;
9207 PL_op = proto_perl->Top;
9210 PL_Xpv = (XPV*)NULL;
9211 PL_na = proto_perl->Tna;
9213 PL_statbuf = proto_perl->Tstatbuf;
9214 PL_statcache = proto_perl->Tstatcache;
9215 PL_statgv = gv_dup(proto_perl->Tstatgv);
9216 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9218 PL_timesbuf = proto_perl->Ttimesbuf;
9221 PL_tainted = proto_perl->Ttainted;
9222 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9223 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9224 PL_rs = sv_dup_inc(proto_perl->Trs);
9225 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9226 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9227 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9228 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9229 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9230 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9231 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9233 PL_restartop = proto_perl->Trestartop;
9234 PL_in_eval = proto_perl->Tin_eval;
9235 PL_delaymagic = proto_perl->Tdelaymagic;
9236 PL_dirty = proto_perl->Tdirty;
9237 PL_localizing = proto_perl->Tlocalizing;
9239 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9240 PL_protect = proto_perl->Tprotect;
9242 PL_errors = sv_dup_inc(proto_perl->Terrors);
9243 PL_av_fetch_sv = Nullsv;
9244 PL_hv_fetch_sv = Nullsv;
9245 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9246 PL_modcount = proto_perl->Tmodcount;
9247 PL_lastgotoprobe = Nullop;
9248 PL_dumpindent = proto_perl->Tdumpindent;
9250 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9251 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9252 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9253 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9254 PL_sortcxix = proto_perl->Tsortcxix;
9255 PL_efloatbuf = Nullch; /* reinits on demand */
9256 PL_efloatsize = 0; /* reinits on demand */
9260 PL_screamfirst = NULL;
9261 PL_screamnext = NULL;
9262 PL_maxscream = -1; /* reinits on demand */
9263 PL_lastscream = Nullsv;
9265 PL_watchaddr = NULL;
9266 PL_watchok = Nullch;
9268 PL_regdummy = proto_perl->Tregdummy;
9269 PL_regcomp_parse = Nullch;
9270 PL_regxend = Nullch;
9271 PL_regcode = (regnode*)NULL;
9274 PL_regprecomp = Nullch;
9279 PL_seen_zerolen = 0;
9281 PL_regcomp_rx = (regexp*)NULL;
9283 PL_colorset = 0; /* reinits PL_colors[] */
9284 /*PL_colors[6] = {0,0,0,0,0,0};*/
9285 PL_reg_whilem_seen = 0;
9286 PL_reginput = Nullch;
9289 PL_regstartp = (I32*)NULL;
9290 PL_regendp = (I32*)NULL;
9291 PL_reglastparen = (U32*)NULL;
9292 PL_regtill = Nullch;
9294 PL_reg_start_tmp = (char**)NULL;
9295 PL_reg_start_tmpl = 0;
9296 PL_regdata = (struct reg_data*)NULL;
9299 PL_reg_eval_set = 0;
9301 PL_regprogram = (regnode*)NULL;
9303 PL_regcc = (CURCUR*)NULL;
9304 PL_reg_call_cc = (struct re_cc_state*)NULL;
9305 PL_reg_re = (regexp*)NULL;
9306 PL_reg_ganch = Nullch;
9308 PL_reg_magic = (MAGIC*)NULL;
9310 PL_reg_oldcurpm = (PMOP*)NULL;
9311 PL_reg_curpm = (PMOP*)NULL;
9312 PL_reg_oldsaved = Nullch;
9313 PL_reg_oldsavedlen = 0;
9315 PL_reg_leftiter = 0;
9316 PL_reg_poscache = Nullch;
9317 PL_reg_poscache_size= 0;
9319 /* RE engine - function pointers */
9320 PL_regcompp = proto_perl->Tregcompp;
9321 PL_regexecp = proto_perl->Tregexecp;
9322 PL_regint_start = proto_perl->Tregint_start;
9323 PL_regint_string = proto_perl->Tregint_string;
9324 PL_regfree = proto_perl->Tregfree;
9326 PL_reginterp_cnt = 0;
9327 PL_reg_starttry = 0;
9329 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9330 ptr_table_free(PL_ptr_table);
9331 PL_ptr_table = NULL;
9335 return (PerlInterpreter*)pPerl;
9341 #else /* !USE_ITHREADS */
9347 #endif /* USE_ITHREADS */
9350 do_report_used(pTHXo_ SV *sv)
9352 if (SvTYPE(sv) != SVTYPEMASK) {
9353 PerlIO_printf(Perl_debug_log, "****\n");
9359 do_clean_objs(pTHXo_ SV *sv)
9363 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9364 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));)
9365 if (SvWEAKREF(sv)) {
9376 /* XXX Might want to check arrays, etc. */
9379 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9381 do_clean_named_objs(pTHXo_ SV *sv)
9383 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9384 if ( SvOBJECT(GvSV(sv)) ||
9385 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9386 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9387 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9388 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9390 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));)
9398 do_clean_all(pTHXo_ SV *sv)
9400 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) );)
9401 SvFLAGS(sv) |= SVf_BREAK;