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;
140 PL_nice_chunk_size = 0;
143 char *chunk; /* must use New here to match call to */
144 New(704,chunk,1008,char); /* Safefree() in sv_free_arenas() */
145 sv_add_arena(chunk, 1008, 0);
152 S_visit(pTHX_ SVFUNC_t f)
159 for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) {
160 svend = &sva[SvREFCNT(sva)];
161 for (sv = sva + 1; sv < svend; ++sv) {
162 if (SvTYPE(sv) != SVTYPEMASK && SvREFCNT(sv)) {
172 Perl_sv_report_used(pTHX)
174 visit(do_report_used);
178 Perl_sv_clean_objs(pTHX)
180 PL_in_clean_objs = TRUE;
181 visit(do_clean_objs);
182 #ifndef DISABLE_DESTRUCTOR_KLUDGE
183 /* some barnacles may yet remain, clinging to typeglobs */
184 visit(do_clean_named_objs);
186 PL_in_clean_objs = FALSE;
190 Perl_sv_clean_all(pTHX)
193 PL_in_clean_all = TRUE;
194 cleaned = visit(do_clean_all);
195 PL_in_clean_all = FALSE;
200 Perl_sv_free_arenas(pTHX)
204 XPV *arena, *arenanext;
206 /* Free arenas here, but be careful about fake ones. (We assume
207 contiguity of the fake ones with the corresponding real ones.) */
209 for (sva = PL_sv_arenaroot; sva; sva = svanext) {
210 svanext = (SV*) SvANY(sva);
211 while (svanext && SvFAKE(svanext))
212 svanext = (SV*) SvANY(svanext);
215 Safefree((void *)sva);
218 for (arena = PL_xiv_arenaroot; arena; arena = arenanext) {
219 arenanext = (XPV*)arena->xpv_pv;
222 PL_xiv_arenaroot = 0;
224 for (arena = PL_xnv_arenaroot; arena; arena = arenanext) {
225 arenanext = (XPV*)arena->xpv_pv;
228 PL_xnv_arenaroot = 0;
230 for (arena = PL_xrv_arenaroot; arena; arena = arenanext) {
231 arenanext = (XPV*)arena->xpv_pv;
234 PL_xrv_arenaroot = 0;
236 for (arena = PL_xpv_arenaroot; arena; arena = arenanext) {
237 arenanext = (XPV*)arena->xpv_pv;
240 PL_xpv_arenaroot = 0;
242 for (arena = (XPV*)PL_xpviv_arenaroot; arena; arena = arenanext) {
243 arenanext = (XPV*)arena->xpv_pv;
246 PL_xpviv_arenaroot = 0;
248 for (arena = (XPV*)PL_xpvnv_arenaroot; arena; arena = arenanext) {
249 arenanext = (XPV*)arena->xpv_pv;
252 PL_xpvnv_arenaroot = 0;
254 for (arena = (XPV*)PL_xpvcv_arenaroot; arena; arena = arenanext) {
255 arenanext = (XPV*)arena->xpv_pv;
258 PL_xpvcv_arenaroot = 0;
260 for (arena = (XPV*)PL_xpvav_arenaroot; arena; arena = arenanext) {
261 arenanext = (XPV*)arena->xpv_pv;
264 PL_xpvav_arenaroot = 0;
266 for (arena = (XPV*)PL_xpvhv_arenaroot; arena; arena = arenanext) {
267 arenanext = (XPV*)arena->xpv_pv;
270 PL_xpvhv_arenaroot = 0;
272 for (arena = (XPV*)PL_xpvmg_arenaroot; arena; arena = arenanext) {
273 arenanext = (XPV*)arena->xpv_pv;
276 PL_xpvmg_arenaroot = 0;
278 for (arena = (XPV*)PL_xpvlv_arenaroot; arena; arena = arenanext) {
279 arenanext = (XPV*)arena->xpv_pv;
282 PL_xpvlv_arenaroot = 0;
284 for (arena = (XPV*)PL_xpvbm_arenaroot; arena; arena = arenanext) {
285 arenanext = (XPV*)arena->xpv_pv;
288 PL_xpvbm_arenaroot = 0;
290 for (arena = (XPV*)PL_he_arenaroot; arena; arena = arenanext) {
291 arenanext = (XPV*)arena->xpv_pv;
297 Safefree(PL_nice_chunk);
298 PL_nice_chunk = Nullch;
299 PL_nice_chunk_size = 0;
305 Perl_report_uninit(pTHX)
308 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit,
309 " in ", PL_op_desc[PL_op->op_type]);
311 Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit, "", "");
323 * See comment in more_xiv() -- RAM.
325 PL_xiv_root = *(IV**)xiv;
327 return (XPVIV*)((char*)xiv - STRUCT_OFFSET(XPVIV, xiv_iv));
331 S_del_xiv(pTHX_ XPVIV *p)
333 IV* xiv = (IV*)((char*)(p) + STRUCT_OFFSET(XPVIV, xiv_iv));
335 *(IV**)xiv = PL_xiv_root;
346 New(705, ptr, 1008/sizeof(XPV), XPV);
347 ptr->xpv_pv = (char*)PL_xiv_arenaroot; /* linked list of xiv arenas */
348 PL_xiv_arenaroot = ptr; /* to keep Purify happy */
351 xivend = &xiv[1008 / sizeof(IV) - 1];
352 xiv += (sizeof(XPV) - 1) / sizeof(IV) + 1; /* fudge by size of XPV */
354 while (xiv < xivend) {
355 *(IV**)xiv = (IV *)(xiv + 1);
369 PL_xnv_root = *(NV**)xnv;
371 return (XPVNV*)((char*)xnv - STRUCT_OFFSET(XPVNV, xnv_nv));
375 S_del_xnv(pTHX_ XPVNV *p)
377 NV* xnv = (NV*)((char*)(p) + STRUCT_OFFSET(XPVNV, xnv_nv));
379 *(NV**)xnv = PL_xnv_root;
390 New(711, ptr, 1008/sizeof(XPV), XPV);
391 ptr->xpv_pv = (char*)PL_xnv_arenaroot;
392 PL_xnv_arenaroot = ptr;
395 xnvend = &xnv[1008 / sizeof(NV) - 1];
396 xnv += (sizeof(XPVIV) - 1) / sizeof(NV) + 1; /* fudge by sizeof XPVIV */
398 while (xnv < xnvend) {
399 *(NV**)xnv = (NV*)(xnv + 1);
413 PL_xrv_root = (XRV*)xrv->xrv_rv;
419 S_del_xrv(pTHX_ XRV *p)
422 p->xrv_rv = (SV*)PL_xrv_root;
431 register XRV* xrvend;
433 New(712, ptr, 1008/sizeof(XPV), XPV);
434 ptr->xpv_pv = (char*)PL_xrv_arenaroot;
435 PL_xrv_arenaroot = ptr;
438 xrvend = &xrv[1008 / sizeof(XRV) - 1];
439 xrv += (sizeof(XPV) - 1) / sizeof(XRV) + 1;
441 while (xrv < xrvend) {
442 xrv->xrv_rv = (SV*)(xrv + 1);
456 PL_xpv_root = (XPV*)xpv->xpv_pv;
462 S_del_xpv(pTHX_ XPV *p)
465 p->xpv_pv = (char*)PL_xpv_root;
474 register XPV* xpvend;
475 New(713, xpv, 1008/sizeof(XPV), XPV);
476 xpv->xpv_pv = (char*)PL_xpv_arenaroot;
477 PL_xpv_arenaroot = xpv;
479 xpvend = &xpv[1008 / sizeof(XPV) - 1];
481 while (xpv < xpvend) {
482 xpv->xpv_pv = (char*)(xpv + 1);
495 xpviv = PL_xpviv_root;
496 PL_xpviv_root = (XPVIV*)xpviv->xpv_pv;
502 S_del_xpviv(pTHX_ XPVIV *p)
505 p->xpv_pv = (char*)PL_xpviv_root;
513 register XPVIV* xpviv;
514 register XPVIV* xpvivend;
515 New(714, xpviv, 1008/sizeof(XPVIV), XPVIV);
516 xpviv->xpv_pv = (char*)PL_xpviv_arenaroot;
517 PL_xpviv_arenaroot = xpviv;
519 xpvivend = &xpviv[1008 / sizeof(XPVIV) - 1];
520 PL_xpviv_root = ++xpviv;
521 while (xpviv < xpvivend) {
522 xpviv->xpv_pv = (char*)(xpviv + 1);
535 xpvnv = PL_xpvnv_root;
536 PL_xpvnv_root = (XPVNV*)xpvnv->xpv_pv;
542 S_del_xpvnv(pTHX_ XPVNV *p)
545 p->xpv_pv = (char*)PL_xpvnv_root;
553 register XPVNV* xpvnv;
554 register XPVNV* xpvnvend;
555 New(715, xpvnv, 1008/sizeof(XPVNV), XPVNV);
556 xpvnv->xpv_pv = (char*)PL_xpvnv_arenaroot;
557 PL_xpvnv_arenaroot = xpvnv;
559 xpvnvend = &xpvnv[1008 / sizeof(XPVNV) - 1];
560 PL_xpvnv_root = ++xpvnv;
561 while (xpvnv < xpvnvend) {
562 xpvnv->xpv_pv = (char*)(xpvnv + 1);
575 xpvcv = PL_xpvcv_root;
576 PL_xpvcv_root = (XPVCV*)xpvcv->xpv_pv;
582 S_del_xpvcv(pTHX_ XPVCV *p)
585 p->xpv_pv = (char*)PL_xpvcv_root;
593 register XPVCV* xpvcv;
594 register XPVCV* xpvcvend;
595 New(716, xpvcv, 1008/sizeof(XPVCV), XPVCV);
596 xpvcv->xpv_pv = (char*)PL_xpvcv_arenaroot;
597 PL_xpvcv_arenaroot = xpvcv;
599 xpvcvend = &xpvcv[1008 / sizeof(XPVCV) - 1];
600 PL_xpvcv_root = ++xpvcv;
601 while (xpvcv < xpvcvend) {
602 xpvcv->xpv_pv = (char*)(xpvcv + 1);
615 xpvav = PL_xpvav_root;
616 PL_xpvav_root = (XPVAV*)xpvav->xav_array;
622 S_del_xpvav(pTHX_ XPVAV *p)
625 p->xav_array = (char*)PL_xpvav_root;
633 register XPVAV* xpvav;
634 register XPVAV* xpvavend;
635 New(717, xpvav, 1008/sizeof(XPVAV), XPVAV);
636 xpvav->xav_array = (char*)PL_xpvav_arenaroot;
637 PL_xpvav_arenaroot = xpvav;
639 xpvavend = &xpvav[1008 / sizeof(XPVAV) - 1];
640 PL_xpvav_root = ++xpvav;
641 while (xpvav < xpvavend) {
642 xpvav->xav_array = (char*)(xpvav + 1);
645 xpvav->xav_array = 0;
655 xpvhv = PL_xpvhv_root;
656 PL_xpvhv_root = (XPVHV*)xpvhv->xhv_array;
662 S_del_xpvhv(pTHX_ XPVHV *p)
665 p->xhv_array = (char*)PL_xpvhv_root;
673 register XPVHV* xpvhv;
674 register XPVHV* xpvhvend;
675 New(718, xpvhv, 1008/sizeof(XPVHV), XPVHV);
676 xpvhv->xhv_array = (char*)PL_xpvhv_arenaroot;
677 PL_xpvhv_arenaroot = xpvhv;
679 xpvhvend = &xpvhv[1008 / sizeof(XPVHV) - 1];
680 PL_xpvhv_root = ++xpvhv;
681 while (xpvhv < xpvhvend) {
682 xpvhv->xhv_array = (char*)(xpvhv + 1);
685 xpvhv->xhv_array = 0;
695 xpvmg = PL_xpvmg_root;
696 PL_xpvmg_root = (XPVMG*)xpvmg->xpv_pv;
702 S_del_xpvmg(pTHX_ XPVMG *p)
705 p->xpv_pv = (char*)PL_xpvmg_root;
713 register XPVMG* xpvmg;
714 register XPVMG* xpvmgend;
715 New(719, xpvmg, 1008/sizeof(XPVMG), XPVMG);
716 xpvmg->xpv_pv = (char*)PL_xpvmg_arenaroot;
717 PL_xpvmg_arenaroot = xpvmg;
719 xpvmgend = &xpvmg[1008 / sizeof(XPVMG) - 1];
720 PL_xpvmg_root = ++xpvmg;
721 while (xpvmg < xpvmgend) {
722 xpvmg->xpv_pv = (char*)(xpvmg + 1);
735 xpvlv = PL_xpvlv_root;
736 PL_xpvlv_root = (XPVLV*)xpvlv->xpv_pv;
742 S_del_xpvlv(pTHX_ XPVLV *p)
745 p->xpv_pv = (char*)PL_xpvlv_root;
753 register XPVLV* xpvlv;
754 register XPVLV* xpvlvend;
755 New(720, xpvlv, 1008/sizeof(XPVLV), XPVLV);
756 xpvlv->xpv_pv = (char*)PL_xpvlv_arenaroot;
757 PL_xpvlv_arenaroot = xpvlv;
759 xpvlvend = &xpvlv[1008 / sizeof(XPVLV) - 1];
760 PL_xpvlv_root = ++xpvlv;
761 while (xpvlv < xpvlvend) {
762 xpvlv->xpv_pv = (char*)(xpvlv + 1);
775 xpvbm = PL_xpvbm_root;
776 PL_xpvbm_root = (XPVBM*)xpvbm->xpv_pv;
782 S_del_xpvbm(pTHX_ XPVBM *p)
785 p->xpv_pv = (char*)PL_xpvbm_root;
793 register XPVBM* xpvbm;
794 register XPVBM* xpvbmend;
795 New(721, xpvbm, 1008/sizeof(XPVBM), XPVBM);
796 xpvbm->xpv_pv = (char*)PL_xpvbm_arenaroot;
797 PL_xpvbm_arenaroot = xpvbm;
799 xpvbmend = &xpvbm[1008 / sizeof(XPVBM) - 1];
800 PL_xpvbm_root = ++xpvbm;
801 while (xpvbm < xpvbmend) {
802 xpvbm->xpv_pv = (char*)(xpvbm + 1);
809 # define my_safemalloc(s) (void*)safexmalloc(717,s)
810 # define my_safefree(p) safexfree((char*)p)
812 # define my_safemalloc(s) (void*)safemalloc(s)
813 # define my_safefree(p) safefree((char*)p)
818 #define new_XIV() my_safemalloc(sizeof(XPVIV))
819 #define del_XIV(p) my_safefree(p)
821 #define new_XNV() my_safemalloc(sizeof(XPVNV))
822 #define del_XNV(p) my_safefree(p)
824 #define new_XRV() my_safemalloc(sizeof(XRV))
825 #define del_XRV(p) my_safefree(p)
827 #define new_XPV() my_safemalloc(sizeof(XPV))
828 #define del_XPV(p) my_safefree(p)
830 #define new_XPVIV() my_safemalloc(sizeof(XPVIV))
831 #define del_XPVIV(p) my_safefree(p)
833 #define new_XPVNV() my_safemalloc(sizeof(XPVNV))
834 #define del_XPVNV(p) my_safefree(p)
836 #define new_XPVCV() my_safemalloc(sizeof(XPVCV))
837 #define del_XPVCV(p) my_safefree(p)
839 #define new_XPVAV() my_safemalloc(sizeof(XPVAV))
840 #define del_XPVAV(p) my_safefree(p)
842 #define new_XPVHV() my_safemalloc(sizeof(XPVHV))
843 #define del_XPVHV(p) my_safefree(p)
845 #define new_XPVMG() my_safemalloc(sizeof(XPVMG))
846 #define del_XPVMG(p) my_safefree(p)
848 #define new_XPVLV() my_safemalloc(sizeof(XPVLV))
849 #define del_XPVLV(p) my_safefree(p)
851 #define new_XPVBM() my_safemalloc(sizeof(XPVBM))
852 #define del_XPVBM(p) my_safefree(p)
856 #define new_XIV() (void*)new_xiv()
857 #define del_XIV(p) del_xiv((XPVIV*) p)
859 #define new_XNV() (void*)new_xnv()
860 #define del_XNV(p) del_xnv((XPVNV*) p)
862 #define new_XRV() (void*)new_xrv()
863 #define del_XRV(p) del_xrv((XRV*) p)
865 #define new_XPV() (void*)new_xpv()
866 #define del_XPV(p) del_xpv((XPV *)p)
868 #define new_XPVIV() (void*)new_xpviv()
869 #define del_XPVIV(p) del_xpviv((XPVIV *)p)
871 #define new_XPVNV() (void*)new_xpvnv()
872 #define del_XPVNV(p) del_xpvnv((XPVNV *)p)
874 #define new_XPVCV() (void*)new_xpvcv()
875 #define del_XPVCV(p) del_xpvcv((XPVCV *)p)
877 #define new_XPVAV() (void*)new_xpvav()
878 #define del_XPVAV(p) del_xpvav((XPVAV *)p)
880 #define new_XPVHV() (void*)new_xpvhv()
881 #define del_XPVHV(p) del_xpvhv((XPVHV *)p)
883 #define new_XPVMG() (void*)new_xpvmg()
884 #define del_XPVMG(p) del_xpvmg((XPVMG *)p)
886 #define new_XPVLV() (void*)new_xpvlv()
887 #define del_XPVLV(p) del_xpvlv((XPVLV *)p)
889 #define new_XPVBM() (void*)new_xpvbm()
890 #define del_XPVBM(p) del_xpvbm((XPVBM *)p)
894 #define new_XPVGV() my_safemalloc(sizeof(XPVGV))
895 #define del_XPVGV(p) my_safefree(p)
897 #define new_XPVFM() my_safemalloc(sizeof(XPVFM))
898 #define del_XPVFM(p) my_safefree(p)
900 #define new_XPVIO() my_safemalloc(sizeof(XPVIO))
901 #define del_XPVIO(p) my_safefree(p)
904 =for apidoc sv_upgrade
906 Upgrade an SV to a more complex form. Use C<SvUPGRADE>. See
913 Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt)
923 if (mt != SVt_PV && SvREADONLY(sv) && SvFAKE(sv)) {
927 if (SvTYPE(sv) == mt)
933 switch (SvTYPE(sv)) {
954 else if (mt < SVt_PVIV)
971 pv = (char*)SvRV(sv);
991 else if (mt == SVt_NV)
1002 del_XPVIV(SvANY(sv));
1012 del_XPVNV(SvANY(sv));
1020 magic = SvMAGIC(sv);
1021 stash = SvSTASH(sv);
1022 del_XPVMG(SvANY(sv));
1025 Perl_croak(aTHX_ "Can't upgrade that kind of scalar");
1030 Perl_croak(aTHX_ "Can't upgrade to undef");
1032 SvANY(sv) = new_XIV();
1036 SvANY(sv) = new_XNV();
1040 SvANY(sv) = new_XRV();
1044 SvANY(sv) = new_XPV();
1050 SvANY(sv) = new_XPVIV();
1060 SvANY(sv) = new_XPVNV();
1068 SvANY(sv) = new_XPVMG();
1074 SvMAGIC(sv) = magic;
1075 SvSTASH(sv) = stash;
1078 SvANY(sv) = new_XPVLV();
1084 SvMAGIC(sv) = magic;
1085 SvSTASH(sv) = stash;
1092 SvANY(sv) = new_XPVAV();
1100 SvMAGIC(sv) = magic;
1101 SvSTASH(sv) = stash;
1107 SvANY(sv) = new_XPVHV();
1115 SvMAGIC(sv) = magic;
1116 SvSTASH(sv) = stash;
1123 SvANY(sv) = new_XPVCV();
1124 Zero(SvANY(sv), 1, XPVCV);
1130 SvMAGIC(sv) = magic;
1131 SvSTASH(sv) = stash;
1134 SvANY(sv) = new_XPVGV();
1140 SvMAGIC(sv) = magic;
1141 SvSTASH(sv) = stash;
1149 SvANY(sv) = new_XPVBM();
1155 SvMAGIC(sv) = magic;
1156 SvSTASH(sv) = stash;
1162 SvANY(sv) = new_XPVFM();
1163 Zero(SvANY(sv), 1, XPVFM);
1169 SvMAGIC(sv) = magic;
1170 SvSTASH(sv) = stash;
1173 SvANY(sv) = new_XPVIO();
1174 Zero(SvANY(sv), 1, XPVIO);
1180 SvMAGIC(sv) = magic;
1181 SvSTASH(sv) = stash;
1182 IoPAGE_LEN(sv) = 60;
1185 SvFLAGS(sv) &= ~SVTYPEMASK;
1191 Perl_sv_backoff(pTHX_ register SV *sv)
1195 char *s = SvPVX(sv);
1196 SvLEN(sv) += SvIVX(sv);
1197 SvPVX(sv) -= SvIVX(sv);
1199 Move(s, SvPVX(sv), SvCUR(sv)+1, char);
1201 SvFLAGS(sv) &= ~SVf_OOK;
1208 Expands the character buffer in the SV. This will use C<sv_unref> and will
1209 upgrade the SV to C<SVt_PV>. Returns a pointer to the character buffer.
1216 Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen)
1220 #ifdef HAS_64K_LIMIT
1221 if (newlen >= 0x10000) {
1222 PerlIO_printf(Perl_debug_log,
1223 "Allocation too large: %"UVxf"\n", (UV)newlen);
1226 #endif /* HAS_64K_LIMIT */
1229 if (SvTYPE(sv) < SVt_PV) {
1230 sv_upgrade(sv, SVt_PV);
1233 else if (SvOOK(sv)) { /* pv is offset? */
1236 if (newlen > SvLEN(sv))
1237 newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */
1238 #ifdef HAS_64K_LIMIT
1239 if (newlen >= 0x10000)
1245 if (newlen > SvLEN(sv)) { /* need more room? */
1246 if (SvLEN(sv) && s) {
1247 #if defined(MYMALLOC) && !defined(LEAKTEST)
1248 STRLEN l = malloced_size((void*)SvPVX(sv));
1254 Renew(s,newlen,char);
1257 New(703,s,newlen,char);
1259 SvLEN_set(sv, newlen);
1265 =for apidoc sv_setiv
1267 Copies an integer into the given SV. Does not handle 'set' magic. See
1274 Perl_sv_setiv(pTHX_ register SV *sv, IV i)
1276 SV_CHECK_THINKFIRST(sv);
1277 switch (SvTYPE(sv)) {
1279 sv_upgrade(sv, SVt_IV);
1282 sv_upgrade(sv, SVt_PVNV);
1286 sv_upgrade(sv, SVt_PVIV);
1295 Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0),
1296 PL_op_desc[PL_op->op_type]);
1298 (void)SvIOK_only(sv); /* validate number */
1304 =for apidoc sv_setiv_mg
1306 Like C<sv_setiv>, but also handles 'set' magic.
1312 Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i)
1319 =for apidoc sv_setuv
1321 Copies an unsigned integer into the given SV. Does not handle 'set' magic.
1328 Perl_sv_setuv(pTHX_ register SV *sv, UV u)
1330 /* With these two if statements:
1331 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1334 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1336 If you wish to remove them, please benchmark to see what the effect is
1338 if (u <= (UV)IV_MAX) {
1339 sv_setiv(sv, (IV)u);
1348 =for apidoc sv_setuv_mg
1350 Like C<sv_setuv>, but also handles 'set' magic.
1356 Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u)
1358 /* With these two if statements:
1359 u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865
1362 u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865
1364 If you wish to remove them, please benchmark to see what the effect is
1366 if (u <= (UV)IV_MAX) {
1367 sv_setiv(sv, (IV)u);
1377 =for apidoc sv_setnv
1379 Copies a double into the given SV. Does not handle 'set' magic. See
1386 Perl_sv_setnv(pTHX_ register SV *sv, NV num)
1388 SV_CHECK_THINKFIRST(sv);
1389 switch (SvTYPE(sv)) {
1392 sv_upgrade(sv, SVt_NV);
1397 sv_upgrade(sv, SVt_PVNV);
1406 Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0),
1407 PL_op_name[PL_op->op_type]);
1410 (void)SvNOK_only(sv); /* validate number */
1415 =for apidoc sv_setnv_mg
1417 Like C<sv_setnv>, but also handles 'set' magic.
1423 Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num)
1430 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 */
1439 for (s = SvPVX(sv), end = s + SvCUR(sv); s < end && d < limit; s++) {
1441 if (ch & 128 && !isPRINT_LC(ch)) {
1450 else if (ch == '\r') {
1454 else if (ch == '\f') {
1458 else if (ch == '\\') {
1462 else if (ch == '\0') {
1466 else if (isPRINT_LC(ch))
1481 Perl_warner(aTHX_ WARN_NUMERIC,
1482 "Argument \"%s\" isn't numeric in %s", tmpbuf,
1483 PL_op_desc[PL_op->op_type]);
1485 Perl_warner(aTHX_ WARN_NUMERIC,
1486 "Argument \"%s\" isn't numeric", tmpbuf);
1489 #define IS_NUMBER_IN_UV 0x01 /* number within UV range (maybe not
1490 int). value returned in pointed-
1492 #define IS_NUMBER_GREATER_THAN_UV_MAX 0x02 /* pointed to UV undefined */
1493 #define IS_NUMBER_NOT_INT 0x04 /* saw . or E notation */
1494 #define IS_NUMBER_NEG 0x08 /* leading minus sign */
1495 #define IS_NUMBER_INFINITY 0x10 /* this is big */
1498 S_grok_number(const char *pv, STRLEN len, UV *valuep)
1501 const char *send = pv + len;
1502 const UV max_div_10 = UV_MAX / 10;
1503 const char max_mod_10 = UV_MAX % 10 + '0';
1506 #ifdef USE_LOCALE_NUMERIC
1507 bool specialradix = FALSE;
1514 numtype = IS_NUMBER_NEG;
1519 /* next must be digit or the radix separator or beginning of infinity */
1521 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
1523 UV value = *s - '0';
1524 /* This construction seems to be more optimiser friendly.
1525 (without it gcc does the isDIGIT test and the *s - '0' separately)
1526 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
1527 In theory the optimiser could deduce how far to unroll the loop
1528 before checking for overflow. */
1529 int digit = *++s - '0';
1530 if (digit >= 0 && digit <= 9) {
1531 value = value * 10 + digit;
1533 if (digit >= 0 && digit <= 9) {
1534 value = value * 10 + digit;
1536 if (digit >= 0 && digit <= 9) {
1537 value = value * 10 + digit;
1539 if (digit >= 0 && digit <= 9) {
1540 value = value * 10 + digit;
1542 if (digit >= 0 && digit <= 9) {
1543 value = value * 10 + digit;
1545 if (digit >= 0 && digit <= 9) {
1546 value = value * 10 + digit;
1548 if (digit >= 0 && digit <= 9) {
1549 value = value * 10 + digit;
1551 if (digit >= 0 && digit <= 9) {
1552 value = value * 10 + digit;
1553 /* Now got 9 digits, so need to check
1554 each time for overflow. */
1556 while (digit >= 0 && digit <= 9
1557 && (value < max_div_10
1558 || (value == max_div_10
1559 && *s <= max_mod_10))) {
1560 value = value * 10 + digit;
1563 if (digit >= 0 && digit <= 9) {
1564 /* value overflowed.
1565 skip the remaining digits, don't
1566 worry about setting *valuep. */
1569 } while (isDIGIT(*s));
1571 IS_NUMBER_GREATER_THAN_UV_MAX;
1582 numtype |= IS_NUMBER_IN_UV;
1588 #ifdef USE_LOCALE_NUMERIC
1589 (specialradix = IS_NUMERIC_RADIX(s, send)) ||
1592 #ifdef USE_LOCALE_NUMERIC
1594 s += SvCUR(PL_numeric_radix_sv);
1598 numtype |= IS_NUMBER_NOT_INT;
1599 while (isDIGIT(*s)) /* optional digits after the radix */
1604 #ifdef USE_LOCALE_NUMERIC
1605 (specialradix = IS_NUMERIC_RADIX(s, send)) ||
1609 #ifdef USE_LOCALE_NUMERIC
1611 s += SvCUR(PL_numeric_radix_sv);
1615 numtype |= IS_NUMBER_NOT_INT;
1616 /* no digits before the radix means we need digits after it */
1620 } while (isDIGIT(*s));
1621 numtype |= IS_NUMBER_IN_UV;
1623 /* integer approximation is valid - it's 0. */
1630 else if (*s == 'I' || *s == 'i') {
1631 s++; if (*s != 'N' && *s != 'n') return 0;
1632 s++; if (*s != 'F' && *s != 'f') return 0;
1633 s++; if (*s == 'I' || *s == 'i') {
1634 s++; if (*s != 'N' && *s != 'n') return 0;
1635 s++; if (*s != 'I' && *s != 'i') return 0;
1636 s++; if (*s != 'T' && *s != 't') return 0;
1637 s++; if (*s != 'Y' && *s != 'y') return 0;
1642 else /* Add test for NaN here. */
1646 numtype &= IS_NUMBER_NEG; /* Keep track of sign */
1647 numtype |= IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
1649 /* we can have an optional exponent part */
1650 if (*s == 'e' || *s == 'E') {
1651 /* The only flag we keep is sign. Blow away any "it's UV" */
1652 numtype &= IS_NUMBER_NEG;
1653 numtype |= IS_NUMBER_NOT_INT;
1655 if (*s == '-' || *s == '+')
1660 } while (isDIGIT(*s));
1670 if (len == 10 && memEQ(pv, "0 but true", 10)) {
1673 return IS_NUMBER_IN_UV;
1679 =for apidoc looks_like_number
1681 Test if an the content of an SV looks like a number (or is a
1682 number). C<Inf> and C<Infinity> are treated as numbers (so will not
1683 issue a non-numeric warning), even if your atof() doesn't grok them.
1689 Perl_looks_like_number(pTHX_ SV *sv)
1691 register char *sbegin;
1698 else if (SvPOKp(sv))
1699 sbegin = SvPV(sv, len);
1701 return 1; /* Historic. Wrong? */
1702 return grok_number(sbegin, len, NULL);
1705 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1706 until proven guilty, assume that things are not that bad... */
1708 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1709 an IV (an assumption perl has been based on to date) it becomes necessary
1710 to remove the assumption that the NV always carries enough precision to
1711 recreate the IV whenever needed, and that the NV is the canonical form.
1712 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1713 precision as an side effect of conversion (which would lead to insanity
1714 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1715 1) to distinguish between IV/UV/NV slots that have cached a valid
1716 conversion where precision was lost and IV/UV/NV slots that have a
1717 valid conversion which has lost no precision
1718 2) to ensure that if a numeric conversion to one form is request that
1719 would lose precision, the precise conversion (or differently
1720 imprecise conversion) is also performed and cached, to prevent
1721 requests for different numeric formats on the same SV causing
1722 lossy conversion chains. (lossless conversion chains are perfectly
1727 SvIOKp is true if the IV slot contains a valid value
1728 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1729 SvNOKp is true if the NV slot contains a valid value
1730 SvNOK is true only if the NV value is accurate
1733 while converting from PV to NV check to see if converting that NV to an
1734 IV(or UV) would lose accuracy over a direct conversion from PV to
1735 IV(or UV). If it would, cache both conversions, return NV, but mark
1736 SV as IOK NOKp (ie not NOK).
1738 while converting from PV to IV check to see if converting that IV to an
1739 NV would lose accuracy over a direct conversion from PV to NV. If it
1740 would, cache both conversions, flag similarly.
1742 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1743 correctly because if IV & NV were set NV *always* overruled.
1744 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1745 changes - now IV and NV together means that the two are interchangeable
1746 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1748 The benefit of this is operations such as pp_add know that if SvIOK is
1749 true for both left and right operands, then integer addition can be
1750 used instead of floating point. (for cases where the result won't
1751 overflow) Before, floating point was always used, which could lead to
1752 loss of precision compared with integer addition.
1754 * making IV and NV equal status should make maths accurate on 64 bit
1756 * may speed up maths somewhat if pp_add and friends start to use
1757 integers when possible instead of fp. (hopefully the overhead in
1758 looking for SvIOK and checking for overflow will not outweigh the
1759 fp to integer speedup)
1760 * will slow down integer operations (callers of SvIV) on "inaccurate"
1761 values, as the change from SvIOK to SvIOKp will cause a call into
1762 sv_2iv each time rather than a macro access direct to the IV slot
1763 * should speed up number->string conversion on integers as IV is
1764 favoured when IV and NV equally accurate
1766 ####################################################################
1767 You had better be using SvIOK_notUV if you want an IV for arithmetic
1768 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1769 SvUOK is true iff UV.
1770 ####################################################################
1772 Your mileage will vary depending your CPUs relative fp to integer
1776 #ifndef NV_PRESERVES_UV
1777 #define IS_NUMBER_UNDERFLOW_IV 1
1778 #define IS_NUMBER_UNDERFLOW_UV 2
1779 #define IS_NUMBER_IV_AND_UV 2
1780 #define IS_NUMBER_OVERFLOW_IV 4
1781 #define IS_NUMBER_OVERFLOW_UV 5
1783 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1785 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1787 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));
1788 if (SvNVX(sv) < (NV)IV_MIN) {
1789 (void)SvIOKp_on(sv);
1792 return IS_NUMBER_UNDERFLOW_IV;
1794 if (SvNVX(sv) > (NV)UV_MAX) {
1795 (void)SvIOKp_on(sv);
1799 return IS_NUMBER_OVERFLOW_UV;
1801 (void)SvIOKp_on(sv);
1803 /* Can't use strtol etc to convert this string. (See truth table in
1805 if (SvNVX(sv) <= (UV)IV_MAX) {
1806 SvIVX(sv) = I_V(SvNVX(sv));
1807 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1808 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1810 /* Integer is imprecise. NOK, IOKp */
1812 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1815 SvUVX(sv) = U_V(SvNVX(sv));
1816 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1817 if (SvUVX(sv) == UV_MAX) {
1818 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1819 possibly be preserved by NV. Hence, it must be overflow.
1821 return IS_NUMBER_OVERFLOW_UV;
1823 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1825 /* Integer is imprecise. NOK, IOKp */
1827 return IS_NUMBER_OVERFLOW_IV;
1829 #endif /* NV_PRESERVES_UV*/
1832 Perl_sv_2iv(pTHX_ register SV *sv)
1836 if (SvGMAGICAL(sv)) {
1841 return I_V(SvNVX(sv));
1843 if (SvPOKp(sv) && SvLEN(sv))
1846 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1847 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1853 if (SvTHINKFIRST(sv)) {
1856 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1857 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1858 return SvIV(tmpstr);
1859 return PTR2IV(SvRV(sv));
1861 if (SvREADONLY(sv) && SvFAKE(sv)) {
1862 sv_force_normal(sv);
1864 if (SvREADONLY(sv) && !SvOK(sv)) {
1865 if (ckWARN(WARN_UNINITIALIZED))
1872 return (IV)(SvUVX(sv));
1879 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1880 * without also getting a cached IV/UV from it at the same time
1881 * (ie PV->NV conversion should detect loss of accuracy and cache
1882 * IV or UV at same time to avoid this. NWC */
1884 if (SvTYPE(sv) == SVt_NV)
1885 sv_upgrade(sv, SVt_PVNV);
1887 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1888 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1889 certainly cast into the IV range at IV_MAX, whereas the correct
1890 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1892 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1893 SvIVX(sv) = I_V(SvNVX(sv));
1894 if (SvNVX(sv) == (NV) SvIVX(sv)
1895 #ifndef NV_PRESERVES_UV
1896 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1897 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1898 /* Don't flag it as "accurately an integer" if the number
1899 came from a (by definition imprecise) NV operation, and
1900 we're outside the range of NV integer precision */
1903 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1904 DEBUG_c(PerlIO_printf(Perl_debug_log,
1905 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1911 /* IV not precise. No need to convert from PV, as NV
1912 conversion would already have cached IV if it detected
1913 that PV->IV would be better than PV->NV->IV
1914 flags already correct - don't set public IOK. */
1915 DEBUG_c(PerlIO_printf(Perl_debug_log,
1916 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1921 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1922 but the cast (NV)IV_MIN rounds to a the value less (more
1923 negative) than IV_MIN which happens to be equal to SvNVX ??
1924 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1925 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1926 (NV)UVX == NVX are both true, but the values differ. :-(
1927 Hopefully for 2s complement IV_MIN is something like
1928 0x8000000000000000 which will be exact. NWC */
1931 SvUVX(sv) = U_V(SvNVX(sv));
1933 (SvNVX(sv) == (NV) SvUVX(sv))
1934 #ifndef NV_PRESERVES_UV
1935 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1936 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1937 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1938 /* Don't flag it as "accurately an integer" if the number
1939 came from a (by definition imprecise) NV operation, and
1940 we're outside the range of NV integer precision */
1946 DEBUG_c(PerlIO_printf(Perl_debug_log,
1947 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1951 return (IV)SvUVX(sv);
1954 else if (SvPOKp(sv) && SvLEN(sv)) {
1956 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
1957 /* We want to avoid a possible problem when we cache an IV which
1958 may be later translated to an NV, and the resulting NV is not
1959 the same as the direct translation of the initial string
1960 (eg 123.456 can shortcut to the IV 123 with atol(), but we must
1961 be careful to ensure that the value with the .456 is around if the
1962 NV value is requested in the future).
1964 This means that if we cache such an IV, we need to cache the
1965 NV as well. Moreover, we trade speed for space, and do not
1966 cache the NV if we are sure it's not needed.
1969 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
1970 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
1971 == IS_NUMBER_IN_UV) {
1972 /* It's defintately an integer, only upgrade to PVIV */
1973 if (SvTYPE(sv) < SVt_PVIV)
1974 sv_upgrade(sv, SVt_PVIV);
1976 } else if (SvTYPE(sv) < SVt_PVNV)
1977 sv_upgrade(sv, SVt_PVNV);
1979 /* If NV preserves UV then we only use the UV value if we know that
1980 we aren't going to call atof() below. If NVs don't preserve UVs
1981 then the value returned may have more precision than atof() will
1982 return, even though value isn't perfectly accurate. */
1983 if ((numtype & (IS_NUMBER_IN_UV
1984 #ifdef NV_PRESERVES_UV
1987 )) == IS_NUMBER_IN_UV) {
1988 /* This won't turn off the public IOK flag if it was set above */
1989 (void)SvIOKp_on(sv);
1991 if (!(numtype & IS_NUMBER_NEG)) {
1993 if (value <= (UV)IV_MAX) {
1994 SvIVX(sv) = (IV)value;
2000 /* 2s complement assumption */
2001 if (value <= (UV)IV_MIN) {
2002 SvIVX(sv) = -(IV)value;
2004 /* Too negative for an IV. This is a double upgrade, but
2005 I'm assuming it will be be rare. */
2006 if (SvTYPE(sv) < SVt_PVNV)
2007 sv_upgrade(sv, SVt_PVNV);
2011 SvNVX(sv) = -(NV)value;
2016 /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we
2017 will be in the previous block to set the IV slot, and the next
2018 block to set the NV slot. So no else here. */
2020 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2021 != IS_NUMBER_IN_UV) {
2022 /* It wasn't an (integer that doesn't overflow the UV). */
2023 SvNVX(sv) = Atof(SvPVX(sv));
2025 if (! numtype && ckWARN(WARN_NUMERIC))
2028 #if defined(USE_LONG_DOUBLE)
2029 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
2030 PTR2UV(sv), SvNVX(sv)));
2032 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
2033 PTR2UV(sv), SvNVX(sv)));
2037 #ifdef NV_PRESERVES_UV
2038 (void)SvIOKp_on(sv);
2040 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2041 SvIVX(sv) = I_V(SvNVX(sv));
2042 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2045 /* Integer is imprecise. NOK, IOKp */
2047 /* UV will not work better than IV */
2049 if (SvNVX(sv) > (NV)UV_MAX) {
2051 /* Integer is inaccurate. NOK, IOKp, is UV */
2055 SvUVX(sv) = U_V(SvNVX(sv));
2056 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
2057 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2061 /* Integer is imprecise. NOK, IOKp, is UV */
2067 #else /* NV_PRESERVES_UV */
2068 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2069 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2070 /* The IV slot will have been set from value returned by
2071 grok_number above. The NV slot has just been set using
2073 assert (SvIOKp(sv));
2075 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2076 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2077 /* Small enough to preserve all bits. */
2078 (void)SvIOKp_on(sv);
2080 SvIVX(sv) = I_V(SvNVX(sv));
2081 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2083 /* Assumption: first non-preserved integer is < IV_MAX,
2084 this NV is in the preserved range, therefore: */
2085 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2087 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);
2091 0 0 already failed to read UV.
2092 0 1 already failed to read UV.
2093 1 0 you won't get here in this case. IV/UV
2094 slot set, public IOK, Atof() unneeded.
2095 1 1 already read UV.
2096 so there's no point in sv_2iuv_non_preserve() attempting
2097 to use atol, strtol, strtoul etc. */
2098 if (sv_2iuv_non_preserve (sv, numtype)
2099 >= IS_NUMBER_OVERFLOW_IV)
2103 #endif /* NV_PRESERVES_UV */
2106 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2108 if (SvTYPE(sv) < SVt_IV)
2109 /* Typically the caller expects that sv_any is not NULL now. */
2110 sv_upgrade(sv, SVt_IV);
2113 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2114 PTR2UV(sv),SvIVX(sv)));
2115 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2119 Perl_sv_2uv(pTHX_ register SV *sv)
2123 if (SvGMAGICAL(sv)) {
2128 return U_V(SvNVX(sv));
2129 if (SvPOKp(sv) && SvLEN(sv))
2132 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2133 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2139 if (SvTHINKFIRST(sv)) {
2142 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2143 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2144 return SvUV(tmpstr);
2145 return PTR2UV(SvRV(sv));
2147 if (SvREADONLY(sv) && SvFAKE(sv)) {
2148 sv_force_normal(sv);
2150 if (SvREADONLY(sv) && !SvOK(sv)) {
2151 if (ckWARN(WARN_UNINITIALIZED))
2161 return (UV)SvIVX(sv);
2165 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2166 * without also getting a cached IV/UV from it at the same time
2167 * (ie PV->NV conversion should detect loss of accuracy and cache
2168 * IV or UV at same time to avoid this. */
2169 /* IV-over-UV optimisation - choose to cache IV if possible */
2171 if (SvTYPE(sv) == SVt_NV)
2172 sv_upgrade(sv, SVt_PVNV);
2174 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2175 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2176 SvIVX(sv) = I_V(SvNVX(sv));
2177 if (SvNVX(sv) == (NV) SvIVX(sv)
2178 #ifndef NV_PRESERVES_UV
2179 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2180 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2181 /* Don't flag it as "accurately an integer" if the number
2182 came from a (by definition imprecise) NV operation, and
2183 we're outside the range of NV integer precision */
2186 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2187 DEBUG_c(PerlIO_printf(Perl_debug_log,
2188 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2194 /* IV not precise. No need to convert from PV, as NV
2195 conversion would already have cached IV if it detected
2196 that PV->IV would be better than PV->NV->IV
2197 flags already correct - don't set public IOK. */
2198 DEBUG_c(PerlIO_printf(Perl_debug_log,
2199 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2204 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2205 but the cast (NV)IV_MIN rounds to a the value less (more
2206 negative) than IV_MIN which happens to be equal to SvNVX ??
2207 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2208 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2209 (NV)UVX == NVX are both true, but the values differ. :-(
2210 Hopefully for 2s complement IV_MIN is something like
2211 0x8000000000000000 which will be exact. NWC */
2214 SvUVX(sv) = U_V(SvNVX(sv));
2216 (SvNVX(sv) == (NV) SvUVX(sv))
2217 #ifndef NV_PRESERVES_UV
2218 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2219 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2220 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2221 /* Don't flag it as "accurately an integer" if the number
2222 came from a (by definition imprecise) NV operation, and
2223 we're outside the range of NV integer precision */
2228 DEBUG_c(PerlIO_printf(Perl_debug_log,
2229 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2235 else if (SvPOKp(sv) && SvLEN(sv)) {
2237 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2239 /* We want to avoid a possible problem when we cache a UV which
2240 may be later translated to an NV, and the resulting NV is not
2241 the translation of the initial data.
2243 This means that if we cache such a UV, we need to cache the
2244 NV as well. Moreover, we trade speed for space, and do not
2245 cache the NV if not needed.
2248 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2249 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2250 == IS_NUMBER_IN_UV) {
2251 /* It's defintately an integer, only upgrade to PVIV */
2252 if (SvTYPE(sv) < SVt_PVIV)
2253 sv_upgrade(sv, SVt_PVIV);
2255 } else if (SvTYPE(sv) < SVt_PVNV)
2256 sv_upgrade(sv, SVt_PVNV);
2258 /* If NV preserves UV then we only use the UV value if we know that
2259 we aren't going to call atof() below. If NVs don't preserve UVs
2260 then the value returned may have more precision than atof() will
2261 return, even though it isn't accurate. */
2262 if ((numtype & (IS_NUMBER_IN_UV
2263 #ifdef NV_PRESERVES_UV
2266 )) == IS_NUMBER_IN_UV) {
2267 /* This won't turn off the public IOK flag if it was set above */
2268 (void)SvIOKp_on(sv);
2270 if (!(numtype & IS_NUMBER_NEG)) {
2272 if (value <= (UV)IV_MAX) {
2273 SvIVX(sv) = (IV)value;
2275 /* it didn't overflow, and it was positive. */
2280 /* 2s complement assumption */
2281 if (value <= (UV)IV_MIN) {
2282 SvIVX(sv) = -(IV)value;
2284 /* Too negative for an IV. This is a double upgrade, but
2285 I'm assuming it will be be rare. */
2286 if (SvTYPE(sv) < SVt_PVNV)
2287 sv_upgrade(sv, SVt_PVNV);
2291 SvNVX(sv) = -(NV)value;
2297 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2298 != IS_NUMBER_IN_UV) {
2299 /* It wasn't an integer, or it overflowed the UV. */
2300 SvNVX(sv) = Atof(SvPVX(sv));
2302 if (! numtype && ckWARN(WARN_NUMERIC))
2305 #if defined(USE_LONG_DOUBLE)
2306 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2307 PTR2UV(sv), SvNVX(sv)));
2309 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2310 PTR2UV(sv), SvNVX(sv)));
2313 #ifdef NV_PRESERVES_UV
2314 (void)SvIOKp_on(sv);
2316 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2317 SvIVX(sv) = I_V(SvNVX(sv));
2318 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2321 /* Integer is imprecise. NOK, IOKp */
2323 /* UV will not work better than IV */
2325 if (SvNVX(sv) > (NV)UV_MAX) {
2327 /* Integer is inaccurate. NOK, IOKp, is UV */
2331 SvUVX(sv) = U_V(SvNVX(sv));
2332 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2333 NV preservse UV so can do correct comparison. */
2334 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2338 /* Integer is imprecise. NOK, IOKp, is UV */
2343 #else /* NV_PRESERVES_UV */
2344 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2345 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2346 /* The UV slot will have been set from value returned by
2347 grok_number above. The NV slot has just been set using
2349 assert (SvIOKp(sv));
2351 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2352 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2353 /* Small enough to preserve all bits. */
2354 (void)SvIOKp_on(sv);
2356 SvIVX(sv) = I_V(SvNVX(sv));
2357 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2359 /* Assumption: first non-preserved integer is < IV_MAX,
2360 this NV is in the preserved range, therefore: */
2361 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2363 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);
2366 sv_2iuv_non_preserve (sv, numtype);
2368 #endif /* NV_PRESERVES_UV */
2372 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2373 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2376 if (SvTYPE(sv) < SVt_IV)
2377 /* Typically the caller expects that sv_any is not NULL now. */
2378 sv_upgrade(sv, SVt_IV);
2382 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2383 PTR2UV(sv),SvUVX(sv)));
2384 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2388 Perl_sv_2nv(pTHX_ register SV *sv)
2392 if (SvGMAGICAL(sv)) {
2396 if (SvPOKp(sv) && SvLEN(sv)) {
2397 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2398 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2400 return Atof(SvPVX(sv));
2404 return (NV)SvUVX(sv);
2406 return (NV)SvIVX(sv);
2409 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2410 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2416 if (SvTHINKFIRST(sv)) {
2419 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2420 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2421 return SvNV(tmpstr);
2422 return PTR2NV(SvRV(sv));
2424 if (SvREADONLY(sv) && SvFAKE(sv)) {
2425 sv_force_normal(sv);
2427 if (SvREADONLY(sv) && !SvOK(sv)) {
2428 if (ckWARN(WARN_UNINITIALIZED))
2433 if (SvTYPE(sv) < SVt_NV) {
2434 if (SvTYPE(sv) == SVt_IV)
2435 sv_upgrade(sv, SVt_PVNV);
2437 sv_upgrade(sv, SVt_NV);
2438 #if defined(USE_LONG_DOUBLE)
2440 STORE_NUMERIC_LOCAL_SET_STANDARD();
2441 PerlIO_printf(Perl_debug_log,
2442 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2443 PTR2UV(sv), SvNVX(sv));
2444 RESTORE_NUMERIC_LOCAL();
2448 STORE_NUMERIC_LOCAL_SET_STANDARD();
2449 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2450 PTR2UV(sv), SvNVX(sv));
2451 RESTORE_NUMERIC_LOCAL();
2455 else if (SvTYPE(sv) < SVt_PVNV)
2456 sv_upgrade(sv, SVt_PVNV);
2457 if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2460 else if (SvIOKp(sv) &&
2461 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || /* XXX check this logic */
2462 !grok_number(SvPVX(sv), SvCUR(sv),NULL)))
2464 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2465 #ifdef NV_PRESERVES_UV
2468 /* Only set the public NV OK flag if this NV preserves the IV */
2469 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2470 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2471 : (SvIVX(sv) == I_V(SvNVX(sv))))
2477 else if (SvPOKp(sv) && SvLEN(sv)) {
2479 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2480 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2482 #ifdef NV_PRESERVES_UV
2483 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2484 == IS_NUMBER_IN_UV) {
2485 /* It's defintately an integer */
2486 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2488 SvNVX(sv) = Atof(SvPVX(sv));
2491 SvNVX(sv) = Atof(SvPVX(sv));
2492 /* Only set the public NV OK flag if this NV preserves the value in
2493 the PV at least as well as an IV/UV would.
2494 Not sure how to do this 100% reliably. */
2495 /* if that shift count is out of range then Configure's test is
2496 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2498 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2499 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2500 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2501 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2502 /* Can't use strtol etc to convert this string, so don't try.
2503 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2506 /* value has been set. It may not be precise. */
2507 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2508 /* 2s complement assumption for (UV)IV_MIN */
2509 SvNOK_on(sv); /* Integer is too negative. */
2514 if (numtype & IS_NUMBER_NEG) {
2515 SvIVX(sv) = -(IV)value;
2516 } else if (value <= (UV)IV_MAX) {
2517 SvIVX(sv) = (IV)value;
2523 if (numtype & IS_NUMBER_NOT_INT) {
2524 /* I believe that even if the original PV had decimals,
2525 they are lost beyond the limit of the FP precision.
2526 However, neither is canonical, so both only get p
2527 flags. NWC, 2000/11/25 */
2528 /* Both already have p flags, so do nothing */
2531 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2532 if (SvIVX(sv) == I_V(nv)) {
2537 /* It had no "." so it must be integer. */
2540 /* between IV_MAX and NV(UV_MAX).
2541 Could be slightly > UV_MAX */
2543 if (numtype & IS_NUMBER_NOT_INT) {
2544 /* UV and NV both imprecise. */
2546 UV nv_as_uv = U_V(nv);
2548 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2559 #endif /* NV_PRESERVES_UV */
2562 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2564 if (SvTYPE(sv) < SVt_NV)
2565 /* Typically the caller expects that sv_any is not NULL now. */
2566 /* XXX Ilya implies that this is a bug in callers that assume this
2567 and ideally should be fixed. */
2568 sv_upgrade(sv, SVt_NV);
2571 #if defined(USE_LONG_DOUBLE)
2573 STORE_NUMERIC_LOCAL_SET_STANDARD();
2574 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2575 PTR2UV(sv), SvNVX(sv));
2576 RESTORE_NUMERIC_LOCAL();
2580 STORE_NUMERIC_LOCAL_SET_STANDARD();
2581 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2582 PTR2UV(sv), SvNVX(sv));
2583 RESTORE_NUMERIC_LOCAL();
2589 /* Caller must validate PVX */
2591 S_asIV(pTHX_ SV *sv)
2594 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2596 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2597 == IS_NUMBER_IN_UV) {
2598 /* It's defintately an integer */
2599 if (numtype & IS_NUMBER_NEG) {
2600 if (value < (UV)IV_MIN)
2603 if (value < (UV)IV_MAX)
2608 if (ckWARN(WARN_NUMERIC))
2611 return I_V(Atof(SvPVX(sv)));
2615 S_asUV(pTHX_ SV *sv)
2618 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2620 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2621 == IS_NUMBER_IN_UV) {
2622 /* It's defintately an integer */
2623 if (!(numtype & IS_NUMBER_NEG))
2627 if (ckWARN(WARN_NUMERIC))
2630 return U_V(Atof(SvPVX(sv)));
2634 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2637 return sv_2pv(sv, &n_a);
2640 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2642 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2644 char *ptr = buf + TYPE_CHARS(UV);
2658 *--ptr = '0' + (uv % 10);
2667 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2669 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2673 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2678 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2679 char *tmpbuf = tbuf;
2685 if (SvGMAGICAL(sv)) {
2686 if (flags & SV_GMAGIC)
2694 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2696 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2701 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2706 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2707 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2714 if (SvTHINKFIRST(sv)) {
2717 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2718 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2719 return SvPV(tmpstr,*lp);
2726 switch (SvTYPE(sv)) {
2728 if ( ((SvFLAGS(sv) &
2729 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2730 == (SVs_OBJECT|SVs_RMG))
2731 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2732 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2733 regexp *re = (regexp *)mg->mg_obj;
2736 char *fptr = "msix";
2741 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2743 while((ch = *fptr++)) {
2745 reflags[left++] = ch;
2748 reflags[right--] = ch;
2753 reflags[left] = '-';
2757 mg->mg_len = re->prelen + 4 + left;
2758 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2759 Copy("(?", mg->mg_ptr, 2, char);
2760 Copy(reflags, mg->mg_ptr+2, left, char);
2761 Copy(":", mg->mg_ptr+left+2, 1, char);
2762 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2763 mg->mg_ptr[mg->mg_len - 1] = ')';
2764 mg->mg_ptr[mg->mg_len] = 0;
2766 PL_reginterp_cnt += re->program[0].next_off;
2778 case SVt_PVBM: if (SvROK(sv))
2781 s = "SCALAR"; break;
2782 case SVt_PVLV: s = "LVALUE"; break;
2783 case SVt_PVAV: s = "ARRAY"; break;
2784 case SVt_PVHV: s = "HASH"; break;
2785 case SVt_PVCV: s = "CODE"; break;
2786 case SVt_PVGV: s = "GLOB"; break;
2787 case SVt_PVFM: s = "FORMAT"; break;
2788 case SVt_PVIO: s = "IO"; break;
2789 default: s = "UNKNOWN"; break;
2793 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2796 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2802 if (SvREADONLY(sv) && !SvOK(sv)) {
2803 if (ckWARN(WARN_UNINITIALIZED))
2809 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2810 /* I'm assuming that if both IV and NV are equally valid then
2811 converting the IV is going to be more efficient */
2812 U32 isIOK = SvIOK(sv);
2813 U32 isUIOK = SvIsUV(sv);
2814 char buf[TYPE_CHARS(UV)];
2817 if (SvTYPE(sv) < SVt_PVIV)
2818 sv_upgrade(sv, SVt_PVIV);
2820 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2822 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2823 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2824 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2825 SvCUR_set(sv, ebuf - ptr);
2835 else if (SvNOKp(sv)) {
2836 if (SvTYPE(sv) < SVt_PVNV)
2837 sv_upgrade(sv, SVt_PVNV);
2838 /* The +20 is pure guesswork. Configure test needed. --jhi */
2839 SvGROW(sv, NV_DIG + 20);
2841 olderrno = errno; /* some Xenix systems wipe out errno here */
2843 if (SvNVX(sv) == 0.0)
2844 (void)strcpy(s,"0");
2848 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2851 #ifdef FIXNEGATIVEZERO
2852 if (*s == '-' && s[1] == '0' && !s[2])
2862 if (ckWARN(WARN_UNINITIALIZED)
2863 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2866 if (SvTYPE(sv) < SVt_PV)
2867 /* Typically the caller expects that sv_any is not NULL now. */
2868 sv_upgrade(sv, SVt_PV);
2871 *lp = s - SvPVX(sv);
2874 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2875 PTR2UV(sv),SvPVX(sv)));
2879 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2880 /* Sneaky stuff here */
2884 tsv = newSVpv(tmpbuf, 0);
2900 len = strlen(tmpbuf);
2902 #ifdef FIXNEGATIVEZERO
2903 if (len == 2 && t[0] == '-' && t[1] == '0') {
2908 (void)SvUPGRADE(sv, SVt_PV);
2910 s = SvGROW(sv, len + 1);
2919 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2922 return sv_2pvbyte(sv, &n_a);
2926 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2928 sv_utf8_downgrade(sv,0);
2929 return SvPV(sv,*lp);
2933 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2936 return sv_2pvutf8(sv, &n_a);
2940 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2942 sv_utf8_upgrade(sv);
2943 return SvPV(sv,*lp);
2946 /* This function is only called on magical items */
2948 Perl_sv_2bool(pTHX_ register SV *sv)
2957 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2958 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
2959 return SvTRUE(tmpsv);
2960 return SvRV(sv) != 0;
2963 register XPV* Xpvtmp;
2964 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2965 (*Xpvtmp->xpv_pv > '0' ||
2966 Xpvtmp->xpv_cur > 1 ||
2967 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2974 return SvIVX(sv) != 0;
2977 return SvNVX(sv) != 0.0;
2985 =for apidoc sv_utf8_upgrade
2987 Convert the PV of an SV to its UTF8-encoded form.
2988 Forces the SV to string form it it is not already.
2989 Always sets the SvUTF8 flag to avoid future validity checks even
2990 if all the bytes have hibit clear.
2996 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2998 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3002 =for apidoc sv_utf8_upgrade_flags
3004 Convert the PV of an SV to its UTF8-encoded form.
3005 Forces the SV to string form it it is not already.
3006 Always sets the SvUTF8 flag to avoid future validity checks even
3007 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3008 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3009 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3015 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3025 (void) sv_2pv_flags(sv,&len, flags);
3033 if (SvREADONLY(sv) && SvFAKE(sv)) {
3034 sv_force_normal(sv);
3037 /* This function could be much more efficient if we had a FLAG in SVs
3038 * to signal if there are any hibit chars in the PV.
3039 * Given that there isn't make loop fast as possible
3041 s = (U8 *) SvPVX(sv);
3042 e = (U8 *) SvEND(sv);
3046 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3052 len = SvCUR(sv) + 1; /* Plus the \0 */
3053 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3054 SvCUR(sv) = len - 1;
3056 Safefree(s); /* No longer using what was there before. */
3057 SvLEN(sv) = len; /* No longer know the real size. */
3059 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3065 =for apidoc sv_utf8_downgrade
3067 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3068 This may not be possible if the PV contains non-byte encoding characters;
3069 if this is the case, either returns false or, if C<fail_ok> is not
3076 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3078 if (SvPOK(sv) && SvUTF8(sv)) {
3083 if (SvREADONLY(sv) && SvFAKE(sv))
3084 sv_force_normal(sv);
3085 s = (U8 *) SvPV(sv, len);
3086 if (!utf8_to_bytes(s, &len)) {
3089 #ifdef USE_BYTES_DOWNGRADES
3090 else if (IN_BYTES) {
3092 U8 *e = (U8 *) SvEND(sv);
3095 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3096 if (first && ch > 255) {
3098 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3099 PL_op_desc[PL_op->op_type]);
3101 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3108 len = (d - (U8 *) SvPVX(sv));
3113 Perl_croak(aTHX_ "Wide character in %s",
3114 PL_op_desc[PL_op->op_type]);
3116 Perl_croak(aTHX_ "Wide character");
3127 =for apidoc sv_utf8_encode
3129 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3130 flag so that it looks like octets again. Used as a building block
3131 for encode_utf8 in Encode.xs
3137 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3139 (void) sv_utf8_upgrade(sv);
3144 =for apidoc sv_utf8_decode
3146 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3147 turn of SvUTF8 if needed so that we see characters. Used as a building block
3148 for decode_utf8 in Encode.xs
3156 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3162 /* The octets may have got themselves encoded - get them back as bytes */
3163 if (!sv_utf8_downgrade(sv, TRUE))
3166 /* it is actually just a matter of turning the utf8 flag on, but
3167 * we want to make sure everything inside is valid utf8 first.
3169 c = (U8 *) SvPVX(sv);
3170 if (!is_utf8_string(c, SvCUR(sv)+1))
3172 e = (U8 *) SvEND(sv);
3175 if (!UTF8_IS_INVARIANT(ch)) {
3185 /* Note: sv_setsv() should not be called with a source string that needs
3186 * to be reused, since it may destroy the source string if it is marked
3191 =for apidoc sv_setsv
3193 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3194 The source SV may be destroyed if it is mortal. Does not handle 'set'
3195 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3201 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3202 for binary compatibility only
3205 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3207 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3211 =for apidoc sv_setsv_flags
3213 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3214 The source SV may be destroyed if it is mortal. Does not handle 'set'
3215 magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
3216 appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
3217 in terms of this function.
3223 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3225 register U32 sflags;
3231 SV_CHECK_THINKFIRST(dstr);
3233 sstr = &PL_sv_undef;
3234 stype = SvTYPE(sstr);
3235 dtype = SvTYPE(dstr);
3239 /* There's a lot of redundancy below but we're going for speed here */
3244 if (dtype != SVt_PVGV) {
3245 (void)SvOK_off(dstr);
3253 sv_upgrade(dstr, SVt_IV);
3256 sv_upgrade(dstr, SVt_PVNV);
3260 sv_upgrade(dstr, SVt_PVIV);
3263 (void)SvIOK_only(dstr);
3264 SvIVX(dstr) = SvIVX(sstr);
3267 if (SvTAINTED(sstr))
3278 sv_upgrade(dstr, SVt_NV);
3283 sv_upgrade(dstr, SVt_PVNV);
3286 SvNVX(dstr) = SvNVX(sstr);
3287 (void)SvNOK_only(dstr);
3288 if (SvTAINTED(sstr))
3296 sv_upgrade(dstr, SVt_RV);
3297 else if (dtype == SVt_PVGV &&
3298 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3301 if (GvIMPORTED(dstr) != GVf_IMPORTED
3302 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3304 GvIMPORTED_on(dstr);
3315 sv_upgrade(dstr, SVt_PV);
3318 if (dtype < SVt_PVIV)
3319 sv_upgrade(dstr, SVt_PVIV);
3322 if (dtype < SVt_PVNV)
3323 sv_upgrade(dstr, SVt_PVNV);
3330 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3331 PL_op_name[PL_op->op_type]);
3333 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3337 if (dtype <= SVt_PVGV) {
3339 if (dtype != SVt_PVGV) {
3340 char *name = GvNAME(sstr);
3341 STRLEN len = GvNAMELEN(sstr);
3342 sv_upgrade(dstr, SVt_PVGV);
3343 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3344 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3345 GvNAME(dstr) = savepvn(name, len);
3346 GvNAMELEN(dstr) = len;
3347 SvFAKE_on(dstr); /* can coerce to non-glob */
3349 /* ahem, death to those who redefine active sort subs */
3350 else if (PL_curstackinfo->si_type == PERLSI_SORT
3351 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3352 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3355 #ifdef GV_SHARED_CHECK
3356 if (GvSHARED((GV*)dstr)) {
3357 Perl_croak(aTHX_ PL_no_modify);
3361 (void)SvOK_off(dstr);
3362 GvINTRO_off(dstr); /* one-shot flag */
3364 GvGP(dstr) = gp_ref(GvGP(sstr));
3365 if (SvTAINTED(sstr))
3367 if (GvIMPORTED(dstr) != GVf_IMPORTED
3368 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3370 GvIMPORTED_on(dstr);
3378 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3380 if (SvTYPE(sstr) != stype) {
3381 stype = SvTYPE(sstr);
3382 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3386 if (stype == SVt_PVLV)
3387 (void)SvUPGRADE(dstr, SVt_PVNV);
3389 (void)SvUPGRADE(dstr, stype);
3392 sflags = SvFLAGS(sstr);
3394 if (sflags & SVf_ROK) {
3395 if (dtype >= SVt_PV) {
3396 if (dtype == SVt_PVGV) {
3397 SV *sref = SvREFCNT_inc(SvRV(sstr));
3399 int intro = GvINTRO(dstr);
3401 #ifdef GV_SHARED_CHECK
3402 if (GvSHARED((GV*)dstr)) {
3403 Perl_croak(aTHX_ PL_no_modify);
3410 GvINTRO_off(dstr); /* one-shot flag */
3411 Newz(602,gp, 1, GP);
3412 GvGP(dstr) = gp_ref(gp);
3413 GvSV(dstr) = NEWSV(72,0);
3414 GvLINE(dstr) = CopLINE(PL_curcop);
3415 GvEGV(dstr) = (GV*)dstr;
3418 switch (SvTYPE(sref)) {
3421 SAVESPTR(GvAV(dstr));
3423 dref = (SV*)GvAV(dstr);
3424 GvAV(dstr) = (AV*)sref;
3425 if (!GvIMPORTED_AV(dstr)
3426 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3428 GvIMPORTED_AV_on(dstr);
3433 SAVESPTR(GvHV(dstr));
3435 dref = (SV*)GvHV(dstr);
3436 GvHV(dstr) = (HV*)sref;
3437 if (!GvIMPORTED_HV(dstr)
3438 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3440 GvIMPORTED_HV_on(dstr);
3445 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3446 SvREFCNT_dec(GvCV(dstr));
3447 GvCV(dstr) = Nullcv;
3448 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3449 PL_sub_generation++;
3451 SAVESPTR(GvCV(dstr));
3454 dref = (SV*)GvCV(dstr);
3455 if (GvCV(dstr) != (CV*)sref) {
3456 CV* cv = GvCV(dstr);
3458 if (!GvCVGEN((GV*)dstr) &&
3459 (CvROOT(cv) || CvXSUB(cv)))
3461 /* ahem, death to those who redefine
3462 * active sort subs */
3463 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3464 PL_sortcop == CvSTART(cv))
3466 "Can't redefine active sort subroutine %s",
3467 GvENAME((GV*)dstr));
3468 /* Redefining a sub - warning is mandatory if
3469 it was a const and its value changed. */
3470 if (ckWARN(WARN_REDEFINE)
3472 && (!CvCONST((CV*)sref)
3473 || sv_cmp(cv_const_sv(cv),
3474 cv_const_sv((CV*)sref)))))
3476 Perl_warner(aTHX_ WARN_REDEFINE,
3478 ? "Constant subroutine %s redefined"
3479 : "Subroutine %s redefined",
3480 GvENAME((GV*)dstr));
3483 cv_ckproto(cv, (GV*)dstr,
3484 SvPOK(sref) ? SvPVX(sref) : Nullch);
3486 GvCV(dstr) = (CV*)sref;
3487 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3488 GvASSUMECV_on(dstr);
3489 PL_sub_generation++;
3491 if (!GvIMPORTED_CV(dstr)
3492 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3494 GvIMPORTED_CV_on(dstr);
3499 SAVESPTR(GvIOp(dstr));
3501 dref = (SV*)GvIOp(dstr);
3502 GvIOp(dstr) = (IO*)sref;
3506 SAVESPTR(GvFORM(dstr));
3508 dref = (SV*)GvFORM(dstr);
3509 GvFORM(dstr) = (CV*)sref;
3513 SAVESPTR(GvSV(dstr));
3515 dref = (SV*)GvSV(dstr);
3517 if (!GvIMPORTED_SV(dstr)
3518 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3520 GvIMPORTED_SV_on(dstr);
3528 if (SvTAINTED(sstr))
3533 (void)SvOOK_off(dstr); /* backoff */
3535 Safefree(SvPVX(dstr));
3536 SvLEN(dstr)=SvCUR(dstr)=0;
3539 (void)SvOK_off(dstr);
3540 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3542 if (sflags & SVp_NOK) {
3544 /* Only set the public OK flag if the source has public OK. */
3545 if (sflags & SVf_NOK)
3546 SvFLAGS(dstr) |= SVf_NOK;
3547 SvNVX(dstr) = SvNVX(sstr);
3549 if (sflags & SVp_IOK) {
3550 (void)SvIOKp_on(dstr);
3551 if (sflags & SVf_IOK)
3552 SvFLAGS(dstr) |= SVf_IOK;
3553 if (sflags & SVf_IVisUV)
3555 SvIVX(dstr) = SvIVX(sstr);
3557 if (SvAMAGIC(sstr)) {
3561 else if (sflags & SVp_POK) {
3564 * Check to see if we can just swipe the string. If so, it's a
3565 * possible small lose on short strings, but a big win on long ones.
3566 * It might even be a win on short strings if SvPVX(dstr)
3567 * has to be allocated and SvPVX(sstr) has to be freed.
3570 if (SvTEMP(sstr) && /* slated for free anyway? */
3571 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3572 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3573 SvLEN(sstr) && /* and really is a string */
3574 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3576 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3578 SvFLAGS(dstr) &= ~SVf_OOK;
3579 Safefree(SvPVX(dstr) - SvIVX(dstr));
3581 else if (SvLEN(dstr))
3582 Safefree(SvPVX(dstr));
3584 (void)SvPOK_only(dstr);
3585 SvPV_set(dstr, SvPVX(sstr));
3586 SvLEN_set(dstr, SvLEN(sstr));
3587 SvCUR_set(dstr, SvCUR(sstr));
3590 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3591 SvPV_set(sstr, Nullch);
3596 else { /* have to copy actual string */
3597 STRLEN len = SvCUR(sstr);
3599 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3600 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3601 SvCUR_set(dstr, len);
3602 *SvEND(dstr) = '\0';
3603 (void)SvPOK_only(dstr);
3605 if (sflags & SVf_UTF8)
3608 if (sflags & SVp_NOK) {
3610 if (sflags & SVf_NOK)
3611 SvFLAGS(dstr) |= SVf_NOK;
3612 SvNVX(dstr) = SvNVX(sstr);
3614 if (sflags & SVp_IOK) {
3615 (void)SvIOKp_on(dstr);
3616 if (sflags & SVf_IOK)
3617 SvFLAGS(dstr) |= SVf_IOK;
3618 if (sflags & SVf_IVisUV)
3620 SvIVX(dstr) = SvIVX(sstr);
3623 else if (sflags & SVp_IOK) {
3624 if (sflags & SVf_IOK)
3625 (void)SvIOK_only(dstr);
3627 (void)SvOK_off(dstr);
3628 (void)SvIOKp_on(dstr);
3630 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3631 if (sflags & SVf_IVisUV)
3633 SvIVX(dstr) = SvIVX(sstr);
3634 if (sflags & SVp_NOK) {
3635 if (sflags & SVf_NOK)
3636 (void)SvNOK_on(dstr);
3638 (void)SvNOKp_on(dstr);
3639 SvNVX(dstr) = SvNVX(sstr);
3642 else if (sflags & SVp_NOK) {
3643 if (sflags & SVf_NOK)
3644 (void)SvNOK_only(dstr);
3646 (void)SvOK_off(dstr);
3649 SvNVX(dstr) = SvNVX(sstr);
3652 if (dtype == SVt_PVGV) {
3653 if (ckWARN(WARN_MISC))
3654 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3657 (void)SvOK_off(dstr);
3659 if (SvTAINTED(sstr))
3664 =for apidoc sv_setsv_mg
3666 Like C<sv_setsv>, but also handles 'set' magic.
3672 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3674 sv_setsv(dstr,sstr);
3679 =for apidoc sv_setpvn
3681 Copies a string into an SV. The C<len> parameter indicates the number of
3682 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3688 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3690 register char *dptr;
3692 SV_CHECK_THINKFIRST(sv);
3698 /* len is STRLEN which is unsigned, need to copy to signed */
3701 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3703 (void)SvUPGRADE(sv, SVt_PV);
3705 SvGROW(sv, len + 1);
3707 Move(ptr,dptr,len,char);
3710 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3715 =for apidoc sv_setpvn_mg
3717 Like C<sv_setpvn>, but also handles 'set' magic.
3723 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3725 sv_setpvn(sv,ptr,len);
3730 =for apidoc sv_setpv
3732 Copies a string into an SV. The string must be null-terminated. Does not
3733 handle 'set' magic. See C<sv_setpv_mg>.
3739 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3741 register STRLEN len;
3743 SV_CHECK_THINKFIRST(sv);
3749 (void)SvUPGRADE(sv, SVt_PV);
3751 SvGROW(sv, len + 1);
3752 Move(ptr,SvPVX(sv),len+1,char);
3754 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3759 =for apidoc sv_setpv_mg
3761 Like C<sv_setpv>, but also handles 'set' magic.
3767 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3774 =for apidoc sv_usepvn
3776 Tells an SV to use C<ptr> to find its string value. Normally the string is
3777 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3778 The C<ptr> should point to memory that was allocated by C<malloc>. The
3779 string length, C<len>, must be supplied. This function will realloc the
3780 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3781 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3782 See C<sv_usepvn_mg>.
3788 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3790 SV_CHECK_THINKFIRST(sv);
3791 (void)SvUPGRADE(sv, SVt_PV);
3796 (void)SvOOK_off(sv);
3797 if (SvPVX(sv) && SvLEN(sv))
3798 Safefree(SvPVX(sv));
3799 Renew(ptr, len+1, char);
3802 SvLEN_set(sv, len+1);
3804 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3809 =for apidoc sv_usepvn_mg
3811 Like C<sv_usepvn>, but also handles 'set' magic.
3817 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3819 sv_usepvn(sv,ptr,len);
3824 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3826 if (SvREADONLY(sv)) {
3828 char *pvx = SvPVX(sv);
3829 STRLEN len = SvCUR(sv);
3830 U32 hash = SvUVX(sv);
3831 SvGROW(sv, len + 1);
3832 Move(pvx,SvPVX(sv),len,char);
3836 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3838 else if (PL_curcop != &PL_compiling)
3839 Perl_croak(aTHX_ PL_no_modify);
3842 sv_unref_flags(sv, flags);
3843 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3848 Perl_sv_force_normal(pTHX_ register SV *sv)
3850 sv_force_normal_flags(sv, 0);
3856 Efficient removal of characters from the beginning of the string buffer.
3857 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3858 the string buffer. The C<ptr> becomes the first character of the adjusted
3865 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3869 register STRLEN delta;
3871 if (!ptr || !SvPOKp(sv))
3873 SV_CHECK_THINKFIRST(sv);
3874 if (SvTYPE(sv) < SVt_PVIV)
3875 sv_upgrade(sv,SVt_PVIV);
3878 if (!SvLEN(sv)) { /* make copy of shared string */
3879 char *pvx = SvPVX(sv);
3880 STRLEN len = SvCUR(sv);
3881 SvGROW(sv, len + 1);
3882 Move(pvx,SvPVX(sv),len,char);
3886 SvFLAGS(sv) |= SVf_OOK;
3888 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3889 delta = ptr - SvPVX(sv);
3897 =for apidoc sv_catpvn
3899 Concatenates the string onto the end of the string which is in the SV. The
3900 C<len> indicates number of bytes to copy. If the SV has the UTF8
3901 status set, then the bytes appended should be valid UTF8.
3902 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3907 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
3908 for binary compatibility only
3911 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
3913 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
3917 =for apidoc sv_catpvn_flags
3919 Concatenates the string onto the end of the string which is in the SV. The
3920 C<len> indicates number of bytes to copy. If the SV has the UTF8
3921 status set, then the bytes appended should be valid UTF8.
3922 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3923 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3924 in terms of this function.
3930 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3935 dstr = SvPV_force_flags(dsv, dlen, flags);
3936 SvGROW(dsv, dlen + slen + 1);
3939 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3942 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3947 =for apidoc sv_catpvn_mg
3949 Like C<sv_catpvn>, but also handles 'set' magic.
3955 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3957 sv_catpvn(sv,ptr,len);
3962 =for apidoc sv_catsv
3964 Concatenates the string from SV C<ssv> onto the end of the string in
3965 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3966 not 'set' magic. See C<sv_catsv_mg>.
3970 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
3971 for binary compatibility only
3974 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3976 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
3980 =for apidoc sv_catsv_flags
3982 Concatenates the string from SV C<ssv> onto the end of the string in
3983 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
3984 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3985 and C<sv_catsv_nomg> are implemented in terms of this function.
3990 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3996 if ((spv = SvPV(ssv, slen))) {
3997 bool sutf8 = DO_UTF8(ssv);
4000 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4002 dutf8 = DO_UTF8(dsv);
4004 if (dutf8 != sutf8) {
4006 /* Not modifying source SV, so taking a temporary copy. */
4007 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4009 sv_utf8_upgrade(csv);
4010 spv = SvPV(csv, slen);
4013 sv_utf8_upgrade_nomg(dsv);
4015 sv_catpvn_nomg(dsv, spv, slen);
4020 =for apidoc sv_catsv_mg
4022 Like C<sv_catsv>, but also handles 'set' magic.
4028 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4035 =for apidoc sv_catpv
4037 Concatenates the string onto the end of the string which is in the SV.
4038 If the SV has the UTF8 status set, then the bytes appended should be
4039 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4044 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4046 register STRLEN len;
4052 junk = SvPV_force(sv, tlen);
4054 SvGROW(sv, tlen + len + 1);
4057 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4059 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4064 =for apidoc sv_catpv_mg
4066 Like C<sv_catpv>, but also handles 'set' magic.
4072 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4079 Perl_newSV(pTHX_ STRLEN len)
4085 sv_upgrade(sv, SVt_PV);
4086 SvGROW(sv, len + 1);
4091 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
4094 =for apidoc sv_magic
4096 Adds magic to an SV.
4102 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4106 if (SvREADONLY(sv)) {
4107 if (PL_curcop != &PL_compiling
4108 /* XXX this used to be !strchr("gBf", how), which seems to
4109 * implicity be equal to !strchr("gBf\0", how), ie \0 matches
4110 * too. I find this suprising, but have hadded PERL_MAGIC_sv
4111 * to the list of things to check - DAPM 19-May-01 */
4112 && how != PERL_MAGIC_regex_global
4113 && how != PERL_MAGIC_bm
4114 && how != PERL_MAGIC_fm
4115 && how != PERL_MAGIC_sv
4118 Perl_croak(aTHX_ PL_no_modify);
4121 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4122 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4123 if (how == PERL_MAGIC_taint)
4129 (void)SvUPGRADE(sv, SVt_PVMG);
4131 Newz(702,mg, 1, MAGIC);
4132 mg->mg_moremagic = SvMAGIC(sv);
4135 /* Some magic sontains a reference loop, where the sv and object refer to
4136 each other. To prevent a avoid a reference loop that would prevent such
4137 objects being freed, we look for such loops and if we find one we avoid
4138 incrementing the object refcount. */
4139 if (!obj || obj == sv ||
4140 how == PERL_MAGIC_arylen ||
4141 how == PERL_MAGIC_qr ||
4142 (SvTYPE(obj) == SVt_PVGV &&
4143 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4144 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4145 GvFORM(obj) == (CV*)sv)))
4150 mg->mg_obj = SvREFCNT_inc(obj);
4151 mg->mg_flags |= MGf_REFCOUNTED;
4154 mg->mg_len = namlen;
4157 mg->mg_ptr = savepvn(name, namlen);
4158 else if (namlen == HEf_SVKEY)
4159 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4164 mg->mg_virtual = &PL_vtbl_sv;
4166 case PERL_MAGIC_overload:
4167 mg->mg_virtual = &PL_vtbl_amagic;
4169 case PERL_MAGIC_overload_elem:
4170 mg->mg_virtual = &PL_vtbl_amagicelem;
4172 case PERL_MAGIC_overload_table:
4173 mg->mg_virtual = &PL_vtbl_ovrld;
4176 mg->mg_virtual = &PL_vtbl_bm;
4178 case PERL_MAGIC_regdata:
4179 mg->mg_virtual = &PL_vtbl_regdata;
4181 case PERL_MAGIC_regdatum:
4182 mg->mg_virtual = &PL_vtbl_regdatum;
4184 case PERL_MAGIC_env:
4185 mg->mg_virtual = &PL_vtbl_env;
4188 mg->mg_virtual = &PL_vtbl_fm;
4190 case PERL_MAGIC_envelem:
4191 mg->mg_virtual = &PL_vtbl_envelem;
4193 case PERL_MAGIC_regex_global:
4194 mg->mg_virtual = &PL_vtbl_mglob;
4196 case PERL_MAGIC_isa:
4197 mg->mg_virtual = &PL_vtbl_isa;
4199 case PERL_MAGIC_isaelem:
4200 mg->mg_virtual = &PL_vtbl_isaelem;
4202 case PERL_MAGIC_nkeys:
4203 mg->mg_virtual = &PL_vtbl_nkeys;
4205 case PERL_MAGIC_dbfile:
4209 case PERL_MAGIC_dbline:
4210 mg->mg_virtual = &PL_vtbl_dbline;
4213 case PERL_MAGIC_mutex:
4214 mg->mg_virtual = &PL_vtbl_mutex;
4216 #endif /* USE_THREADS */
4217 #ifdef USE_LOCALE_COLLATE
4218 case PERL_MAGIC_collxfrm:
4219 mg->mg_virtual = &PL_vtbl_collxfrm;
4221 #endif /* USE_LOCALE_COLLATE */
4222 case PERL_MAGIC_tied:
4223 mg->mg_virtual = &PL_vtbl_pack;
4225 case PERL_MAGIC_tiedelem:
4226 case PERL_MAGIC_tiedscalar:
4227 mg->mg_virtual = &PL_vtbl_packelem;
4230 mg->mg_virtual = &PL_vtbl_regexp;
4232 case PERL_MAGIC_sig:
4233 mg->mg_virtual = &PL_vtbl_sig;
4235 case PERL_MAGIC_sigelem:
4236 mg->mg_virtual = &PL_vtbl_sigelem;
4238 case PERL_MAGIC_taint:
4239 mg->mg_virtual = &PL_vtbl_taint;
4242 case PERL_MAGIC_uvar:
4243 mg->mg_virtual = &PL_vtbl_uvar;
4245 case PERL_MAGIC_vec:
4246 mg->mg_virtual = &PL_vtbl_vec;
4248 case PERL_MAGIC_substr:
4249 mg->mg_virtual = &PL_vtbl_substr;
4251 case PERL_MAGIC_defelem:
4252 mg->mg_virtual = &PL_vtbl_defelem;
4254 case PERL_MAGIC_glob:
4255 mg->mg_virtual = &PL_vtbl_glob;
4257 case PERL_MAGIC_arylen:
4258 mg->mg_virtual = &PL_vtbl_arylen;
4260 case PERL_MAGIC_pos:
4261 mg->mg_virtual = &PL_vtbl_pos;
4263 case PERL_MAGIC_backref:
4264 mg->mg_virtual = &PL_vtbl_backref;
4266 case PERL_MAGIC_ext:
4267 /* Reserved for use by extensions not perl internals. */
4268 /* Useful for attaching extension internal data to perl vars. */
4269 /* Note that multiple extensions may clash if magical scalars */
4270 /* etc holding private data from one are passed to another. */
4274 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4278 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4282 =for apidoc sv_unmagic
4284 Removes magic from an SV.
4290 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4294 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4297 for (mg = *mgp; mg; mg = *mgp) {
4298 if (mg->mg_type == type) {
4299 MGVTBL* vtbl = mg->mg_virtual;
4300 *mgp = mg->mg_moremagic;
4301 if (vtbl && vtbl->svt_free)
4302 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4303 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4304 if (mg->mg_len >= 0)
4305 Safefree(mg->mg_ptr);
4306 else if (mg->mg_len == HEf_SVKEY)
4307 SvREFCNT_dec((SV*)mg->mg_ptr);
4309 if (mg->mg_flags & MGf_REFCOUNTED)
4310 SvREFCNT_dec(mg->mg_obj);
4314 mgp = &mg->mg_moremagic;
4318 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4325 =for apidoc sv_rvweaken
4333 Perl_sv_rvweaken(pTHX_ SV *sv)
4336 if (!SvOK(sv)) /* let undefs pass */
4339 Perl_croak(aTHX_ "Can't weaken a nonreference");
4340 else if (SvWEAKREF(sv)) {
4341 if (ckWARN(WARN_MISC))
4342 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4346 sv_add_backref(tsv, sv);
4353 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4357 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4358 av = (AV*)mg->mg_obj;
4361 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4362 SvREFCNT_dec(av); /* for sv_magic */
4368 S_sv_del_backref(pTHX_ SV *sv)
4375 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4376 Perl_croak(aTHX_ "panic: del_backref");
4377 av = (AV *)mg->mg_obj;
4382 svp[i] = &PL_sv_undef; /* XXX */
4389 =for apidoc sv_insert
4391 Inserts a string at the specified offset/length within the SV. Similar to
4392 the Perl substr() function.
4398 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4402 register char *midend;
4403 register char *bigend;
4409 Perl_croak(aTHX_ "Can't modify non-existent substring");
4410 SvPV_force(bigstr, curlen);
4411 (void)SvPOK_only_UTF8(bigstr);
4412 if (offset + len > curlen) {
4413 SvGROW(bigstr, offset+len+1);
4414 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4415 SvCUR_set(bigstr, offset+len);
4419 i = littlelen - len;
4420 if (i > 0) { /* string might grow */
4421 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4422 mid = big + offset + len;
4423 midend = bigend = big + SvCUR(bigstr);
4426 while (midend > mid) /* shove everything down */
4427 *--bigend = *--midend;
4428 Move(little,big+offset,littlelen,char);
4434 Move(little,SvPVX(bigstr)+offset,len,char);
4439 big = SvPVX(bigstr);
4442 bigend = big + SvCUR(bigstr);
4444 if (midend > bigend)
4445 Perl_croak(aTHX_ "panic: sv_insert");
4447 if (mid - big > bigend - midend) { /* faster to shorten from end */
4449 Move(little, mid, littlelen,char);
4452 i = bigend - midend;
4454 Move(midend, mid, i,char);
4458 SvCUR_set(bigstr, mid - big);
4461 else if ((i = mid - big)) { /* faster from front */
4462 midend -= littlelen;
4464 sv_chop(bigstr,midend-i);
4469 Move(little, mid, littlelen,char);
4471 else if (littlelen) {
4472 midend -= littlelen;
4473 sv_chop(bigstr,midend);
4474 Move(little,midend,littlelen,char);
4477 sv_chop(bigstr,midend);
4483 =for apidoc sv_replace
4485 Make the first argument a copy of the second, then delete the original.
4491 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4493 U32 refcnt = SvREFCNT(sv);
4494 SV_CHECK_THINKFIRST(sv);
4495 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4496 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4497 if (SvMAGICAL(sv)) {
4501 sv_upgrade(nsv, SVt_PVMG);
4502 SvMAGIC(nsv) = SvMAGIC(sv);
4503 SvFLAGS(nsv) |= SvMAGICAL(sv);
4509 assert(!SvREFCNT(sv));
4510 StructCopy(nsv,sv,SV);
4511 SvREFCNT(sv) = refcnt;
4512 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4517 =for apidoc sv_clear
4519 Clear an SV, making it empty. Does not free the memory used by the SV
4526 Perl_sv_clear(pTHX_ register SV *sv)
4530 assert(SvREFCNT(sv) == 0);
4533 if (PL_defstash) { /* Still have a symbol table? */
4538 Zero(&tmpref, 1, SV);
4539 sv_upgrade(&tmpref, SVt_RV);
4541 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4542 SvREFCNT(&tmpref) = 1;
4545 stash = SvSTASH(sv);
4546 destructor = StashHANDLER(stash,DESTROY);
4549 PUSHSTACKi(PERLSI_DESTROY);
4550 SvRV(&tmpref) = SvREFCNT_inc(sv);
4555 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4561 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4563 del_XRV(SvANY(&tmpref));
4566 if (PL_in_clean_objs)
4567 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4569 /* DESTROY gave object new lease on life */
4575 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4576 SvOBJECT_off(sv); /* Curse the object. */
4577 if (SvTYPE(sv) != SVt_PVIO)
4578 --PL_sv_objcount; /* XXX Might want something more general */
4581 if (SvTYPE(sv) >= SVt_PVMG) {
4584 if (SvFLAGS(sv) & SVpad_TYPED)
4585 SvREFCNT_dec(SvSTASH(sv));
4588 switch (SvTYPE(sv)) {
4591 IoIFP(sv) != PerlIO_stdin() &&
4592 IoIFP(sv) != PerlIO_stdout() &&
4593 IoIFP(sv) != PerlIO_stderr())
4595 io_close((IO*)sv, FALSE);
4597 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4598 PerlDir_close(IoDIRP(sv));
4599 IoDIRP(sv) = (DIR*)NULL;
4600 Safefree(IoTOP_NAME(sv));
4601 Safefree(IoFMT_NAME(sv));
4602 Safefree(IoBOTTOM_NAME(sv));
4617 SvREFCNT_dec(LvTARG(sv));
4621 Safefree(GvNAME(sv));
4622 /* cannot decrease stash refcount yet, as we might recursively delete
4623 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4624 of stash until current sv is completely gone.
4625 -- JohnPC, 27 Mar 1998 */
4626 stash = GvSTASH(sv);
4632 (void)SvOOK_off(sv);
4640 SvREFCNT_dec(SvRV(sv));
4642 else if (SvPVX(sv) && SvLEN(sv))
4643 Safefree(SvPVX(sv));
4644 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4645 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4657 switch (SvTYPE(sv)) {
4673 del_XPVIV(SvANY(sv));
4676 del_XPVNV(SvANY(sv));
4679 del_XPVMG(SvANY(sv));
4682 del_XPVLV(SvANY(sv));
4685 del_XPVAV(SvANY(sv));
4688 del_XPVHV(SvANY(sv));
4691 del_XPVCV(SvANY(sv));
4694 del_XPVGV(SvANY(sv));
4695 /* code duplication for increased performance. */
4696 SvFLAGS(sv) &= SVf_BREAK;
4697 SvFLAGS(sv) |= SVTYPEMASK;
4698 /* decrease refcount of the stash that owns this GV, if any */
4700 SvREFCNT_dec(stash);
4701 return; /* not break, SvFLAGS reset already happened */
4703 del_XPVBM(SvANY(sv));
4706 del_XPVFM(SvANY(sv));
4709 del_XPVIO(SvANY(sv));
4712 SvFLAGS(sv) &= SVf_BREAK;
4713 SvFLAGS(sv) |= SVTYPEMASK;
4717 Perl_sv_newref(pTHX_ SV *sv)
4720 ATOMIC_INC(SvREFCNT(sv));
4727 Free the memory used by an SV.
4733 Perl_sv_free(pTHX_ SV *sv)
4735 int refcount_is_zero;
4739 if (SvREFCNT(sv) == 0) {
4740 if (SvFLAGS(sv) & SVf_BREAK)
4742 if (PL_in_clean_all) /* All is fair */
4744 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4745 /* make sure SvREFCNT(sv)==0 happens very seldom */
4746 SvREFCNT(sv) = (~(U32)0)/2;
4749 if (ckWARN_d(WARN_INTERNAL))
4750 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4753 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4754 if (!refcount_is_zero)
4758 if (ckWARN_d(WARN_DEBUGGING))
4759 Perl_warner(aTHX_ WARN_DEBUGGING,
4760 "Attempt to free temp prematurely: SV 0x%"UVxf,
4765 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4766 /* make sure SvREFCNT(sv)==0 happens very seldom */
4767 SvREFCNT(sv) = (~(U32)0)/2;
4778 Returns the length of the string in the SV. See also C<SvCUR>.
4784 Perl_sv_len(pTHX_ register SV *sv)
4793 len = mg_length(sv);
4795 junk = SvPV(sv, len);
4800 =for apidoc sv_len_utf8
4802 Returns the number of characters in the string in an SV, counting wide
4803 UTF8 bytes as a single character.
4809 Perl_sv_len_utf8(pTHX_ register SV *sv)
4815 return mg_length(sv);
4819 U8 *s = (U8*)SvPV(sv, len);
4821 return Perl_utf8_length(aTHX_ s, s + len);
4826 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4831 I32 uoffset = *offsetp;
4837 start = s = (U8*)SvPV(sv, len);
4839 while (s < send && uoffset--)
4843 *offsetp = s - start;
4847 while (s < send && ulen--)
4857 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4866 s = (U8*)SvPV(sv, len);
4868 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4869 send = s + *offsetp;
4873 /* Call utf8n_to_uvchr() to validate the sequence */
4874 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4889 Returns a boolean indicating whether the strings in the two SVs are
4896 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4910 pv1 = SvPV(sv1, cur1);
4917 pv2 = SvPV(sv2, cur2);
4919 /* do not utf8ize the comparands as a side-effect */
4920 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4921 bool is_utf8 = TRUE;
4922 /* UTF-8ness differs */
4923 if (PL_hints & HINT_UTF8_DISTINCT)
4927 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4928 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4933 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4934 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4939 /* Downgrade not possible - cannot be eq */
4945 eq = memEQ(pv1, pv2, cur1);
4956 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4957 string in C<sv1> is less than, equal to, or greater than the string in
4964 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4969 bool pv1tmp = FALSE;
4970 bool pv2tmp = FALSE;
4977 pv1 = SvPV(sv1, cur1);
4984 pv2 = SvPV(sv2, cur2);
4986 /* do not utf8ize the comparands as a side-effect */
4987 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4988 if (PL_hints & HINT_UTF8_DISTINCT)
4989 return SvUTF8(sv1) ? 1 : -1;
4992 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4996 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5002 cmp = cur2 ? -1 : 0;
5006 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5009 cmp = retval < 0 ? -1 : 1;
5010 } else if (cur1 == cur2) {
5013 cmp = cur1 < cur2 ? -1 : 1;
5026 =for apidoc sv_cmp_locale
5028 Compares the strings in two SVs in a locale-aware manner. See
5035 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5037 #ifdef USE_LOCALE_COLLATE
5043 if (PL_collation_standard)
5047 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5049 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5051 if (!pv1 || !len1) {
5062 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5065 return retval < 0 ? -1 : 1;
5068 * When the result of collation is equality, that doesn't mean
5069 * that there are no differences -- some locales exclude some
5070 * characters from consideration. So to avoid false equalities,
5071 * we use the raw string as a tiebreaker.
5077 #endif /* USE_LOCALE_COLLATE */
5079 return sv_cmp(sv1, sv2);
5082 #ifdef USE_LOCALE_COLLATE
5084 * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5085 * scalar data of the variable transformed to such a format that
5086 * a normal memory comparison can be used to compare the data
5087 * according to the locale settings.
5090 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5094 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5095 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5100 Safefree(mg->mg_ptr);
5102 if ((xf = mem_collxfrm(s, len, &xlen))) {
5103 if (SvREADONLY(sv)) {
5106 return xf + sizeof(PL_collation_ix);
5109 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5110 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5123 if (mg && mg->mg_ptr) {
5125 return mg->mg_ptr + sizeof(PL_collation_ix);
5133 #endif /* USE_LOCALE_COLLATE */
5138 Get a line from the filehandle and store it into the SV, optionally
5139 appending to the currently-stored string.
5145 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5149 register STDCHAR rslast;
5150 register STDCHAR *bp;
5154 SV_CHECK_THINKFIRST(sv);
5155 (void)SvUPGRADE(sv, SVt_PV);
5159 if (RsSNARF(PL_rs)) {
5163 else if (RsRECORD(PL_rs)) {
5164 I32 recsize, bytesread;
5167 /* Grab the size of the record we're getting */
5168 recsize = SvIV(SvRV(PL_rs));
5169 (void)SvPOK_only(sv); /* Validate pointer */
5170 buffer = SvGROW(sv, recsize + 1);
5173 /* VMS wants read instead of fread, because fread doesn't respect */
5174 /* RMS record boundaries. This is not necessarily a good thing to be */
5175 /* doing, but we've got no other real choice */
5176 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5178 bytesread = PerlIO_read(fp, buffer, recsize);
5180 SvCUR_set(sv, bytesread);
5181 buffer[bytesread] = '\0';
5182 if (PerlIO_isutf8(fp))
5186 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5188 else if (RsPARA(PL_rs)) {
5193 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5194 if (PerlIO_isutf8(fp)) {
5195 rsptr = SvPVutf8(PL_rs, rslen);
5198 if (SvUTF8(PL_rs)) {
5199 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5200 Perl_croak(aTHX_ "Wide character in $/");
5203 rsptr = SvPV(PL_rs, rslen);
5207 rslast = rslen ? rsptr[rslen - 1] : '\0';
5209 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5210 do { /* to make sure file boundaries work right */
5213 i = PerlIO_getc(fp);
5217 PerlIO_ungetc(fp,i);
5223 /* See if we know enough about I/O mechanism to cheat it ! */
5225 /* This used to be #ifdef test - it is made run-time test for ease
5226 of abstracting out stdio interface. One call should be cheap
5227 enough here - and may even be a macro allowing compile
5231 if (PerlIO_fast_gets(fp)) {
5234 * We're going to steal some values from the stdio struct
5235 * and put EVERYTHING in the innermost loop into registers.
5237 register STDCHAR *ptr;
5241 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5242 /* An ungetc()d char is handled separately from the regular
5243 * buffer, so we getc() it back out and stuff it in the buffer.
5245 i = PerlIO_getc(fp);
5246 if (i == EOF) return 0;
5247 *(--((*fp)->_ptr)) = (unsigned char) i;
5251 /* Here is some breathtakingly efficient cheating */
5253 cnt = PerlIO_get_cnt(fp); /* get count into register */
5254 (void)SvPOK_only(sv); /* validate pointer */
5255 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5256 if (cnt > 80 && SvLEN(sv) > append) {
5257 shortbuffered = cnt - SvLEN(sv) + append + 1;
5258 cnt -= shortbuffered;
5262 /* remember that cnt can be negative */
5263 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5268 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5269 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5270 DEBUG_P(PerlIO_printf(Perl_debug_log,
5271 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5272 DEBUG_P(PerlIO_printf(Perl_debug_log,
5273 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5274 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5275 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5280 while (cnt > 0) { /* this | eat */
5282 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5283 goto thats_all_folks; /* screams | sed :-) */
5287 Copy(ptr, bp, cnt, char); /* this | eat */
5288 bp += cnt; /* screams | dust */
5289 ptr += cnt; /* louder | sed :-) */
5294 if (shortbuffered) { /* oh well, must extend */
5295 cnt = shortbuffered;
5297 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5299 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5300 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5304 DEBUG_P(PerlIO_printf(Perl_debug_log,
5305 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5306 PTR2UV(ptr),(long)cnt));
5307 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5308 DEBUG_P(PerlIO_printf(Perl_debug_log,
5309 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5310 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5311 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5312 /* This used to call 'filbuf' in stdio form, but as that behaves like
5313 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5314 another abstraction. */
5315 i = PerlIO_getc(fp); /* get more characters */
5316 DEBUG_P(PerlIO_printf(Perl_debug_log,
5317 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5318 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5319 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5320 cnt = PerlIO_get_cnt(fp);
5321 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5322 DEBUG_P(PerlIO_printf(Perl_debug_log,
5323 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5325 if (i == EOF) /* all done for ever? */
5326 goto thats_really_all_folks;
5328 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5330 SvGROW(sv, bpx + cnt + 2);
5331 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5333 *bp++ = i; /* store character from PerlIO_getc */
5335 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5336 goto thats_all_folks;
5340 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5341 memNE((char*)bp - rslen, rsptr, rslen))
5342 goto screamer; /* go back to the fray */
5343 thats_really_all_folks:
5345 cnt += shortbuffered;
5346 DEBUG_P(PerlIO_printf(Perl_debug_log,
5347 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5348 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5349 DEBUG_P(PerlIO_printf(Perl_debug_log,
5350 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5351 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5352 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5354 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5355 DEBUG_P(PerlIO_printf(Perl_debug_log,
5356 "Screamer: done, len=%ld, string=|%.*s|\n",
5357 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5362 /*The big, slow, and stupid way */
5365 /* Need to work around EPOC SDK features */
5366 /* On WINS: MS VC5 generates calls to _chkstk, */
5367 /* if a `large' stack frame is allocated */
5368 /* gcc on MARM does not generate calls like these */
5374 register STDCHAR *bpe = buf + sizeof(buf);
5376 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5377 ; /* keep reading */
5381 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5382 /* Accomodate broken VAXC compiler, which applies U8 cast to
5383 * both args of ?: operator, causing EOF to change into 255
5385 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5389 sv_catpvn(sv, (char *) buf, cnt);
5391 sv_setpvn(sv, (char *) buf, cnt);
5393 if (i != EOF && /* joy */
5395 SvCUR(sv) < rslen ||
5396 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5400 * If we're reading from a TTY and we get a short read,
5401 * indicating that the user hit his EOF character, we need
5402 * to notice it now, because if we try to read from the TTY
5403 * again, the EOF condition will disappear.
5405 * The comparison of cnt to sizeof(buf) is an optimization
5406 * that prevents unnecessary calls to feof().
5410 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5415 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5416 while (i != EOF) { /* to make sure file boundaries work right */
5417 i = PerlIO_getc(fp);
5419 PerlIO_ungetc(fp,i);
5425 if (PerlIO_isutf8(fp))
5430 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5437 Auto-increment of the value in the SV.
5443 Perl_sv_inc(pTHX_ register SV *sv)
5452 if (SvTHINKFIRST(sv)) {
5453 if (SvREADONLY(sv)) {
5454 if (PL_curcop != &PL_compiling)
5455 Perl_croak(aTHX_ PL_no_modify);
5459 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5461 i = PTR2IV(SvRV(sv));
5466 flags = SvFLAGS(sv);
5467 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5468 /* It's (privately or publicly) a float, but not tested as an
5469 integer, so test it to see. */
5471 flags = SvFLAGS(sv);
5473 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5474 /* It's publicly an integer, or privately an integer-not-float */
5477 if (SvUVX(sv) == UV_MAX)
5478 sv_setnv(sv, (NV)UV_MAX + 1.0);
5480 (void)SvIOK_only_UV(sv);
5483 if (SvIVX(sv) == IV_MAX)
5484 sv_setuv(sv, (UV)IV_MAX + 1);
5486 (void)SvIOK_only(sv);
5492 if (flags & SVp_NOK) {
5493 (void)SvNOK_only(sv);
5498 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5499 if ((flags & SVTYPEMASK) < SVt_PVIV)
5500 sv_upgrade(sv, SVt_IV);
5501 (void)SvIOK_only(sv);
5506 while (isALPHA(*d)) d++;
5507 while (isDIGIT(*d)) d++;
5509 #ifdef PERL_PRESERVE_IVUV
5510 /* Got to punt this an an integer if needs be, but we don't issue
5511 warnings. Probably ought to make the sv_iv_please() that does
5512 the conversion if possible, and silently. */
5513 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5514 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5515 /* Need to try really hard to see if it's an integer.
5516 9.22337203685478e+18 is an integer.
5517 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5518 so $a="9.22337203685478e+18"; $a+0; $a++
5519 needs to be the same as $a="9.22337203685478e+18"; $a++
5526 /* sv_2iv *should* have made this an NV */
5527 if (flags & SVp_NOK) {
5528 (void)SvNOK_only(sv);
5532 /* I don't think we can get here. Maybe I should assert this
5533 And if we do get here I suspect that sv_setnv will croak. NWC
5535 #if defined(USE_LONG_DOUBLE)
5536 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",
5537 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5539 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5540 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5543 #endif /* PERL_PRESERVE_IVUV */
5544 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5548 while (d >= SvPVX(sv)) {
5556 /* MKS: The original code here died if letters weren't consecutive.
5557 * at least it didn't have to worry about non-C locales. The
5558 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5559 * arranged in order (although not consecutively) and that only
5560 * [A-Za-z] are accepted by isALPHA in the C locale.
5562 if (*d != 'z' && *d != 'Z') {
5563 do { ++*d; } while (!isALPHA(*d));
5566 *(d--) -= 'z' - 'a';
5571 *(d--) -= 'z' - 'a' + 1;
5575 /* oh,oh, the number grew */
5576 SvGROW(sv, SvCUR(sv) + 2);
5578 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5589 Auto-decrement of the value in the SV.
5595 Perl_sv_dec(pTHX_ register SV *sv)
5603 if (SvTHINKFIRST(sv)) {
5604 if (SvREADONLY(sv)) {
5605 if (PL_curcop != &PL_compiling)
5606 Perl_croak(aTHX_ PL_no_modify);
5610 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5612 i = PTR2IV(SvRV(sv));
5617 /* Unlike sv_inc we don't have to worry about string-never-numbers
5618 and keeping them magic. But we mustn't warn on punting */
5619 flags = SvFLAGS(sv);
5620 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5621 /* It's publicly an integer, or privately an integer-not-float */
5624 if (SvUVX(sv) == 0) {
5625 (void)SvIOK_only(sv);
5629 (void)SvIOK_only_UV(sv);
5633 if (SvIVX(sv) == IV_MIN)
5634 sv_setnv(sv, (NV)IV_MIN - 1.0);
5636 (void)SvIOK_only(sv);
5642 if (flags & SVp_NOK) {
5644 (void)SvNOK_only(sv);
5647 if (!(flags & SVp_POK)) {
5648 if ((flags & SVTYPEMASK) < SVt_PVNV)
5649 sv_upgrade(sv, SVt_NV);
5651 (void)SvNOK_only(sv);
5654 #ifdef PERL_PRESERVE_IVUV
5656 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5657 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5658 /* Need to try really hard to see if it's an integer.
5659 9.22337203685478e+18 is an integer.
5660 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5661 so $a="9.22337203685478e+18"; $a+0; $a--
5662 needs to be the same as $a="9.22337203685478e+18"; $a--
5669 /* sv_2iv *should* have made this an NV */
5670 if (flags & SVp_NOK) {
5671 (void)SvNOK_only(sv);
5675 /* I don't think we can get here. Maybe I should assert this
5676 And if we do get here I suspect that sv_setnv will croak. NWC
5678 #if defined(USE_LONG_DOUBLE)
5679 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",
5680 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5682 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5683 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5687 #endif /* PERL_PRESERVE_IVUV */
5688 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5692 =for apidoc sv_mortalcopy
5694 Creates a new SV which is a copy of the original SV. The new SV is marked
5700 /* Make a string that will exist for the duration of the expression
5701 * evaluation. Actually, it may have to last longer than that, but
5702 * hopefully we won't free it until it has been assigned to a
5703 * permanent location. */
5706 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5711 sv_setsv(sv,oldstr);
5713 PL_tmps_stack[++PL_tmps_ix] = sv;
5719 =for apidoc sv_newmortal
5721 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5727 Perl_sv_newmortal(pTHX)
5732 SvFLAGS(sv) = SVs_TEMP;
5734 PL_tmps_stack[++PL_tmps_ix] = sv;
5739 =for apidoc sv_2mortal
5741 Marks an SV as mortal. The SV will be destroyed when the current context
5747 /* same thing without the copying */
5750 Perl_sv_2mortal(pTHX_ register SV *sv)
5754 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5757 PL_tmps_stack[++PL_tmps_ix] = sv;
5765 Creates a new SV and copies a string into it. The reference count for the
5766 SV is set to 1. If C<len> is zero, Perl will compute the length using
5767 strlen(). For efficiency, consider using C<newSVpvn> instead.
5773 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5780 sv_setpvn(sv,s,len);
5785 =for apidoc newSVpvn
5787 Creates a new SV and copies a string into it. The reference count for the
5788 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5789 string. You are responsible for ensuring that the source string is at least
5796 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5801 sv_setpvn(sv,s,len);
5806 =for apidoc newSVpvn_share
5808 Creates a new SV and populates it with a string from
5809 the string table. Turns on READONLY and FAKE.
5810 The idea here is that as string table is used for shared hash
5811 keys these strings will have SvPVX == HeKEY and hash lookup
5812 will avoid string compare.
5818 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5821 bool is_utf8 = FALSE;
5826 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5827 STRLEN tmplen = len;
5828 /* See the note in hv.c:hv_fetch() --jhi */
5829 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5833 PERL_HASH(hash, src, len);
5835 sv_upgrade(sv, SVt_PVIV);
5836 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5848 #if defined(PERL_IMPLICIT_CONTEXT)
5850 Perl_newSVpvf_nocontext(const char* pat, ...)
5855 va_start(args, pat);
5856 sv = vnewSVpvf(pat, &args);
5863 =for apidoc newSVpvf
5865 Creates a new SV an initialize it with the string formatted like
5872 Perl_newSVpvf(pTHX_ const char* pat, ...)
5876 va_start(args, pat);
5877 sv = vnewSVpvf(pat, &args);
5883 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5887 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5894 Creates a new SV and copies a floating point value into it.
5895 The reference count for the SV is set to 1.
5901 Perl_newSVnv(pTHX_ NV n)
5913 Creates a new SV and copies an integer into it. The reference count for the
5920 Perl_newSViv(pTHX_ IV i)
5932 Creates a new SV and copies an unsigned integer into it.
5933 The reference count for the SV is set to 1.
5939 Perl_newSVuv(pTHX_ UV u)
5949 =for apidoc newRV_noinc
5951 Creates an RV wrapper for an SV. The reference count for the original
5952 SV is B<not> incremented.
5958 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5963 sv_upgrade(sv, SVt_RV);
5970 /* newRV_inc is #defined to newRV in sv.h */
5972 Perl_newRV(pTHX_ SV *tmpRef)
5974 return newRV_noinc(SvREFCNT_inc(tmpRef));
5980 Creates a new SV which is an exact duplicate of the original SV.
5985 /* make an exact duplicate of old */
5988 Perl_newSVsv(pTHX_ register SV *old)
5994 if (SvTYPE(old) == SVTYPEMASK) {
5995 if (ckWARN_d(WARN_INTERNAL))
5996 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6011 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6019 char todo[PERL_UCHAR_MAX+1];
6024 if (!*s) { /* reset ?? searches */
6025 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6026 pm->op_pmdynflags &= ~PMdf_USED;
6031 /* reset variables */
6033 if (!HvARRAY(stash))
6036 Zero(todo, 256, char);
6038 i = (unsigned char)*s;
6042 max = (unsigned char)*s++;
6043 for ( ; i <= max; i++) {
6046 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6047 for (entry = HvARRAY(stash)[i];
6049 entry = HeNEXT(entry))
6051 if (!todo[(U8)*HeKEY(entry)])
6053 gv = (GV*)HeVAL(entry);
6055 if (SvTHINKFIRST(sv)) {
6056 if (!SvREADONLY(sv) && SvROK(sv))
6061 if (SvTYPE(sv) >= SVt_PV) {
6063 if (SvPVX(sv) != Nullch)
6070 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6072 #ifdef USE_ENVIRON_ARRAY
6074 environ[0] = Nullch;
6083 Perl_sv_2io(pTHX_ SV *sv)
6089 switch (SvTYPE(sv)) {
6097 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6101 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6103 return sv_2io(SvRV(sv));
6104 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6110 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6117 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6124 return *gvp = Nullgv, Nullcv;
6125 switch (SvTYPE(sv)) {
6144 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6145 tryAMAGICunDEREF(to_cv);
6148 if (SvTYPE(sv) == SVt_PVCV) {
6157 Perl_croak(aTHX_ "Not a subroutine reference");
6162 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6168 if (lref && !GvCVu(gv)) {
6171 tmpsv = NEWSV(704,0);
6172 gv_efullname3(tmpsv, gv, Nullch);
6173 /* XXX this is probably not what they think they're getting.
6174 * It has the same effect as "sub name;", i.e. just a forward
6176 newSUB(start_subparse(FALSE, 0),
6177 newSVOP(OP_CONST, 0, tmpsv),
6182 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6191 Returns true if the SV has a true value by Perl's rules.
6197 Perl_sv_true(pTHX_ register SV *sv)
6203 if ((tXpv = (XPV*)SvANY(sv)) &&
6204 (tXpv->xpv_cur > 1 ||
6205 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6212 return SvIVX(sv) != 0;
6215 return SvNVX(sv) != 0.0;
6217 return sv_2bool(sv);
6223 Perl_sv_iv(pTHX_ register SV *sv)
6227 return (IV)SvUVX(sv);
6234 Perl_sv_uv(pTHX_ register SV *sv)
6239 return (UV)SvIVX(sv);
6245 Perl_sv_nv(pTHX_ register SV *sv)
6253 Perl_sv_pv(pTHX_ SV *sv)
6260 return sv_2pv(sv, &n_a);
6264 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6270 return sv_2pv(sv, lp);
6274 =for apidoc sv_pvn_force
6276 Get a sensible string out of the SV somehow.
6282 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6284 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6288 =for apidoc sv_pvn_force_flags
6290 Get a sensible string out of the SV somehow.
6291 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6292 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6293 implemented in terms of this function.
6299 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6303 if (SvTHINKFIRST(sv) && !SvROK(sv))
6304 sv_force_normal(sv);
6310 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6311 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6312 PL_op_name[PL_op->op_type]);
6315 s = sv_2pv_flags(sv, lp, flags);
6316 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6321 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6322 SvGROW(sv, len + 1);
6323 Move(s,SvPVX(sv),len,char);
6328 SvPOK_on(sv); /* validate pointer */
6330 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6331 PTR2UV(sv),SvPVX(sv)));
6338 Perl_sv_pvbyte(pTHX_ SV *sv)
6340 sv_utf8_downgrade(sv,0);
6345 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6347 sv_utf8_downgrade(sv,0);
6348 return sv_pvn(sv,lp);
6352 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6354 sv_utf8_downgrade(sv,0);
6355 return sv_pvn_force(sv,lp);
6359 Perl_sv_pvutf8(pTHX_ SV *sv)
6361 sv_utf8_upgrade(sv);
6366 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6368 sv_utf8_upgrade(sv);
6369 return sv_pvn(sv,lp);
6373 =for apidoc sv_pvutf8n_force
6375 Get a sensible UTF8-encoded string out of the SV somehow. See
6382 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6384 sv_utf8_upgrade(sv);
6385 return sv_pvn_force(sv,lp);
6389 =for apidoc sv_reftype
6391 Returns a string describing what the SV is a reference to.
6397 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6399 if (ob && SvOBJECT(sv))
6400 return HvNAME(SvSTASH(sv));
6402 switch (SvTYPE(sv)) {
6416 case SVt_PVLV: return "LVALUE";
6417 case SVt_PVAV: return "ARRAY";
6418 case SVt_PVHV: return "HASH";
6419 case SVt_PVCV: return "CODE";
6420 case SVt_PVGV: return "GLOB";
6421 case SVt_PVFM: return "FORMAT";
6422 case SVt_PVIO: return "IO";
6423 default: return "UNKNOWN";
6429 =for apidoc sv_isobject
6431 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6432 object. If the SV is not an RV, or if the object is not blessed, then this
6439 Perl_sv_isobject(pTHX_ SV *sv)
6456 Returns a boolean indicating whether the SV is blessed into the specified
6457 class. This does not check for subtypes; use C<sv_derived_from> to verify
6458 an inheritance relationship.
6464 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6476 return strEQ(HvNAME(SvSTASH(sv)), name);
6482 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6483 it will be upgraded to one. If C<classname> is non-null then the new SV will
6484 be blessed in the specified package. The new SV is returned and its
6485 reference count is 1.
6491 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6497 SV_CHECK_THINKFIRST(rv);
6500 if (SvTYPE(rv) >= SVt_PVMG) {
6501 U32 refcnt = SvREFCNT(rv);
6505 SvREFCNT(rv) = refcnt;
6508 if (SvTYPE(rv) < SVt_RV)
6509 sv_upgrade(rv, SVt_RV);
6510 else if (SvTYPE(rv) > SVt_RV) {
6511 (void)SvOOK_off(rv);
6512 if (SvPVX(rv) && SvLEN(rv))
6513 Safefree(SvPVX(rv));
6523 HV* stash = gv_stashpv(classname, TRUE);
6524 (void)sv_bless(rv, stash);
6530 =for apidoc sv_setref_pv
6532 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6533 argument will be upgraded to an RV. That RV will be modified to point to
6534 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6535 into the SV. The C<classname> argument indicates the package for the
6536 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6537 will be returned and will have a reference count of 1.
6539 Do not use with other Perl types such as HV, AV, SV, CV, because those
6540 objects will become corrupted by the pointer copy process.
6542 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6548 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6551 sv_setsv(rv, &PL_sv_undef);
6555 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6560 =for apidoc sv_setref_iv
6562 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6563 argument will be upgraded to an RV. That RV will be modified to point to
6564 the new SV. The C<classname> argument indicates the package for the
6565 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6566 will be returned and will have a reference count of 1.
6572 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6574 sv_setiv(newSVrv(rv,classname), iv);
6579 =for apidoc sv_setref_uv
6581 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6582 argument will be upgraded to an RV. That RV will be modified to point to
6583 the new SV. The C<classname> argument indicates the package for the
6584 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6585 will be returned and will have a reference count of 1.
6591 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6593 sv_setuv(newSVrv(rv,classname), uv);
6598 =for apidoc sv_setref_nv
6600 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6601 argument will be upgraded to an RV. That RV will be modified to point to
6602 the new SV. The C<classname> argument indicates the package for the
6603 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6604 will be returned and will have a reference count of 1.
6610 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6612 sv_setnv(newSVrv(rv,classname), nv);
6617 =for apidoc sv_setref_pvn
6619 Copies a string into a new SV, optionally blessing the SV. The length of the
6620 string must be specified with C<n>. The C<rv> argument will be upgraded to
6621 an RV. That RV will be modified to point to the new SV. The C<classname>
6622 argument indicates the package for the blessing. Set C<classname> to
6623 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6624 a reference count of 1.
6626 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6632 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6634 sv_setpvn(newSVrv(rv,classname), pv, n);
6639 =for apidoc sv_bless
6641 Blesses an SV into a specified package. The SV must be an RV. The package
6642 must be designated by its stash (see C<gv_stashpv()>). The reference count
6643 of the SV is unaffected.
6649 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6653 Perl_croak(aTHX_ "Can't bless non-reference value");
6655 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6656 if (SvREADONLY(tmpRef))
6657 Perl_croak(aTHX_ PL_no_modify);
6658 if (SvOBJECT(tmpRef)) {
6659 if (SvTYPE(tmpRef) != SVt_PVIO)
6661 SvREFCNT_dec(SvSTASH(tmpRef));
6664 SvOBJECT_on(tmpRef);
6665 if (SvTYPE(tmpRef) != SVt_PVIO)
6667 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6668 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6679 S_sv_unglob(pTHX_ SV *sv)
6683 assert(SvTYPE(sv) == SVt_PVGV);
6688 SvREFCNT_dec(GvSTASH(sv));
6689 GvSTASH(sv) = Nullhv;
6691 sv_unmagic(sv, PERL_MAGIC_glob);
6692 Safefree(GvNAME(sv));
6695 /* need to keep SvANY(sv) in the right arena */
6696 xpvmg = new_XPVMG();
6697 StructCopy(SvANY(sv), xpvmg, XPVMG);
6698 del_XPVGV(SvANY(sv));
6701 SvFLAGS(sv) &= ~SVTYPEMASK;
6702 SvFLAGS(sv) |= SVt_PVMG;
6706 =for apidoc sv_unref_flags
6708 Unsets the RV status of the SV, and decrements the reference count of
6709 whatever was being referenced by the RV. This can almost be thought of
6710 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6711 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6712 (otherwise the decrementing is conditional on the reference count being
6713 different from one or the reference being a readonly SV).
6720 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6724 if (SvWEAKREF(sv)) {
6732 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6734 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6735 sv_2mortal(rv); /* Schedule for freeing later */
6739 =for apidoc sv_unref
6741 Unsets the RV status of the SV, and decrements the reference count of
6742 whatever was being referenced by the RV. This can almost be thought of
6743 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6744 being zero. See C<SvROK_off>.
6750 Perl_sv_unref(pTHX_ SV *sv)
6752 sv_unref_flags(sv, 0);
6756 Perl_sv_taint(pTHX_ SV *sv)
6758 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
6762 Perl_sv_untaint(pTHX_ SV *sv)
6764 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6765 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6772 Perl_sv_tainted(pTHX_ SV *sv)
6774 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6775 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6776 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6783 =for apidoc sv_setpviv
6785 Copies an integer into the given SV, also updating its string value.
6786 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6792 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6794 char buf[TYPE_CHARS(UV)];
6796 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6798 sv_setpvn(sv, ptr, ebuf - ptr);
6803 =for apidoc sv_setpviv_mg
6805 Like C<sv_setpviv>, but also handles 'set' magic.
6811 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6813 char buf[TYPE_CHARS(UV)];
6815 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6817 sv_setpvn(sv, ptr, ebuf - ptr);
6821 #if defined(PERL_IMPLICIT_CONTEXT)
6823 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6827 va_start(args, pat);
6828 sv_vsetpvf(sv, pat, &args);
6834 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6838 va_start(args, pat);
6839 sv_vsetpvf_mg(sv, pat, &args);
6845 =for apidoc sv_setpvf
6847 Processes its arguments like C<sprintf> and sets an SV to the formatted
6848 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6854 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6857 va_start(args, pat);
6858 sv_vsetpvf(sv, pat, &args);
6863 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6865 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6869 =for apidoc sv_setpvf_mg
6871 Like C<sv_setpvf>, but also handles 'set' magic.
6877 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6880 va_start(args, pat);
6881 sv_vsetpvf_mg(sv, pat, &args);
6886 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6888 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6892 #if defined(PERL_IMPLICIT_CONTEXT)
6894 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6898 va_start(args, pat);
6899 sv_vcatpvf(sv, pat, &args);
6904 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6908 va_start(args, pat);
6909 sv_vcatpvf_mg(sv, pat, &args);
6915 =for apidoc sv_catpvf
6917 Processes its arguments like C<sprintf> and appends the formatted
6918 output to an SV. If the appended data contains "wide" characters
6919 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6920 and characters >255 formatted with %c), the original SV might get
6921 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6922 C<SvSETMAGIC()> must typically be called after calling this function
6923 to handle 'set' magic.
6928 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6931 va_start(args, pat);
6932 sv_vcatpvf(sv, pat, &args);
6937 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6939 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6943 =for apidoc sv_catpvf_mg
6945 Like C<sv_catpvf>, but also handles 'set' magic.
6951 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6954 va_start(args, pat);
6955 sv_vcatpvf_mg(sv, pat, &args);
6960 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6962 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6967 =for apidoc sv_vsetpvfn
6969 Works like C<vcatpvfn> but copies the text into the SV instead of
6976 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6978 sv_setpvn(sv, "", 0);
6979 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6983 S_expect_number(pTHX_ char** pattern)
6986 switch (**pattern) {
6987 case '1': case '2': case '3':
6988 case '4': case '5': case '6':
6989 case '7': case '8': case '9':
6990 while (isDIGIT(**pattern))
6991 var = var * 10 + (*(*pattern)++ - '0');
6995 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6998 =for apidoc sv_vcatpvfn
7000 Processes its arguments like C<vsprintf> and appends the formatted output
7001 to an SV. Uses an array of SVs if the C style variable argument list is
7002 missing (NULL). When running with taint checks enabled, indicates via
7003 C<maybe_tainted> if results are untrustworthy (often due to the use of
7010 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7017 static char nullstr[] = "(null)";
7020 /* no matter what, this is a string now */
7021 (void)SvPV_force(sv, origlen);
7023 /* special-case "", "%s", and "%_" */
7026 if (patlen == 2 && pat[0] == '%') {
7030 char *s = va_arg(*args, char*);
7031 sv_catpv(sv, s ? s : nullstr);
7033 else if (svix < svmax) {
7034 sv_catsv(sv, *svargs);
7035 if (DO_UTF8(*svargs))
7041 argsv = va_arg(*args, SV*);
7042 sv_catsv(sv, argsv);
7047 /* See comment on '_' below */
7052 patend = (char*)pat + patlen;
7053 for (p = (char*)pat; p < patend; p = q) {
7056 bool vectorize = FALSE;
7057 bool vectorarg = FALSE;
7058 bool vec_utf = FALSE;
7064 bool has_precis = FALSE;
7066 bool is_utf = FALSE;
7069 U8 utf8buf[UTF8_MAXLEN+1];
7070 STRLEN esignlen = 0;
7072 char *eptr = Nullch;
7074 /* Times 4: a decimal digit takes more than 3 binary digits.
7075 * NV_DIG: mantissa takes than many decimal digits.
7076 * Plus 32: Playing safe. */
7077 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7078 /* large enough for "%#.#f" --chip */
7079 /* what about long double NVs? --jhi */
7082 U8 *vecstr = Null(U8*);
7094 STRLEN dotstrlen = 1;
7095 I32 efix = 0; /* explicit format parameter index */
7096 I32 ewix = 0; /* explicit width index */
7097 I32 epix = 0; /* explicit precision index */
7098 I32 evix = 0; /* explicit vector index */
7099 bool asterisk = FALSE;
7101 /* echo everything up to the next format specification */
7102 for (q = p; q < patend && *q != '%'; ++q) ;
7104 sv_catpvn(sv, p, q - p);
7111 We allow format specification elements in this order:
7112 \d+\$ explicit format parameter index
7114 \*?(\d+\$)?v vector with optional (optionally specified) arg
7115 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7116 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7118 [%bcdefginopsux_DFOUX] format (mandatory)
7120 if (EXPECT_NUMBER(q, width)) {
7161 if (EXPECT_NUMBER(q, ewix))
7170 if ((vectorarg = asterisk)) {
7180 EXPECT_NUMBER(q, width);
7185 vecsv = va_arg(*args, SV*);
7187 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7188 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7189 dotstr = SvPVx(vecsv, dotstrlen);
7194 vecsv = va_arg(*args, SV*);
7195 vecstr = (U8*)SvPVx(vecsv,veclen);
7196 vec_utf = DO_UTF8(vecsv);
7198 else if (efix ? efix <= svmax : svix < svmax) {
7199 vecsv = svargs[efix ? efix-1 : svix++];
7200 vecstr = (U8*)SvPVx(vecsv,veclen);
7201 vec_utf = DO_UTF8(vecsv);
7211 i = va_arg(*args, int);
7213 i = (ewix ? ewix <= svmax : svix < svmax) ?
7214 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7216 width = (i < 0) ? -i : i;
7226 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7229 i = va_arg(*args, int);
7231 i = (ewix ? ewix <= svmax : svix < svmax)
7232 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7233 precis = (i < 0) ? 0 : i;
7238 precis = precis * 10 + (*q++ - '0');
7246 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7257 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7258 if (*(q + 1) == 'l') { /* lld, llf */
7281 argsv = (efix ? efix <= svmax : svix < svmax) ?
7282 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7289 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7291 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7293 eptr = (char*)utf8buf;
7294 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7306 eptr = va_arg(*args, char*);
7308 #ifdef MACOS_TRADITIONAL
7309 /* On MacOS, %#s format is used for Pascal strings */
7314 elen = strlen(eptr);
7317 elen = sizeof nullstr - 1;
7321 eptr = SvPVx(argsv, elen);
7322 if (DO_UTF8(argsv)) {
7323 if (has_precis && precis < elen) {
7325 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7328 if (width) { /* fudge width (can't fudge elen) */
7329 width += elen - sv_len_utf8(argsv);
7338 * The "%_" hack might have to be changed someday,
7339 * if ISO or ANSI decide to use '_' for something.
7340 * So we keep it hidden from users' code.
7344 argsv = va_arg(*args, SV*);
7345 eptr = SvPVx(argsv, elen);
7351 if (has_precis && elen > precis)
7360 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7378 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7388 case 'h': iv = (short)va_arg(*args, int); break;
7389 default: iv = va_arg(*args, int); break;
7390 case 'l': iv = va_arg(*args, long); break;
7391 case 'V': iv = va_arg(*args, IV); break;
7393 case 'q': iv = va_arg(*args, Quad_t); break;
7400 case 'h': iv = (short)iv; break;
7402 case 'l': iv = (long)iv; break;
7405 case 'q': iv = (Quad_t)iv; break;
7412 esignbuf[esignlen++] = plus;
7416 esignbuf[esignlen++] = '-';
7458 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7468 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7469 default: uv = va_arg(*args, unsigned); break;
7470 case 'l': uv = va_arg(*args, unsigned long); break;
7471 case 'V': uv = va_arg(*args, UV); break;
7473 case 'q': uv = va_arg(*args, Quad_t); break;
7480 case 'h': uv = (unsigned short)uv; break;
7482 case 'l': uv = (unsigned long)uv; break;
7485 case 'q': uv = (Quad_t)uv; break;
7491 eptr = ebuf + sizeof ebuf;
7497 p = (char*)((c == 'X')
7498 ? "0123456789ABCDEF" : "0123456789abcdef");
7504 esignbuf[esignlen++] = '0';
7505 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7511 *--eptr = '0' + dig;
7513 if (alt && *eptr != '0')
7519 *--eptr = '0' + dig;
7522 esignbuf[esignlen++] = '0';
7523 esignbuf[esignlen++] = 'b';
7526 default: /* it had better be ten or less */
7527 #if defined(PERL_Y2KWARN)
7528 if (ckWARN(WARN_Y2K)) {
7530 char *s = SvPV(sv,n);
7531 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7532 && (n == 2 || !isDIGIT(s[n-3])))
7534 Perl_warner(aTHX_ WARN_Y2K,
7535 "Possible Y2K bug: %%%c %s",
7536 c, "format string following '19'");
7542 *--eptr = '0' + dig;
7543 } while (uv /= base);
7546 elen = (ebuf + sizeof ebuf) - eptr;
7549 zeros = precis - elen;
7550 else if (precis == 0 && elen == 1 && *eptr == '0')
7555 /* FLOATING POINT */
7558 c = 'f'; /* maybe %F isn't supported here */
7564 /* This is evil, but floating point is even more evil */
7567 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7570 if (c != 'e' && c != 'E') {
7572 (void)Perl_frexp(nv, &i);
7573 if (i == PERL_INT_MIN)
7574 Perl_die(aTHX_ "panic: frexp");
7576 need = BIT_DIGITS(i);
7578 need += has_precis ? precis : 6; /* known default */
7582 need += 20; /* fudge factor */
7583 if (PL_efloatsize < need) {
7584 Safefree(PL_efloatbuf);
7585 PL_efloatsize = need + 20; /* more fudge */
7586 New(906, PL_efloatbuf, PL_efloatsize, char);
7587 PL_efloatbuf[0] = '\0';
7590 eptr = ebuf + sizeof ebuf;
7593 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7595 /* Copy the one or more characters in a long double
7596 * format before the 'base' ([efgEFG]) character to
7597 * the format string. */
7598 static char const prifldbl[] = PERL_PRIfldbl;
7599 char const *p = prifldbl + sizeof(prifldbl) - 3;
7600 while (p >= prifldbl) { *--eptr = *p--; }
7605 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7610 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7622 /* No taint. Otherwise we are in the strange situation
7623 * where printf() taints but print($float) doesn't.
7625 (void)sprintf(PL_efloatbuf, eptr, nv);
7627 eptr = PL_efloatbuf;
7628 elen = strlen(PL_efloatbuf);
7635 i = SvCUR(sv) - origlen;
7638 case 'h': *(va_arg(*args, short*)) = i; break;
7639 default: *(va_arg(*args, int*)) = i; break;
7640 case 'l': *(va_arg(*args, long*)) = i; break;
7641 case 'V': *(va_arg(*args, IV*)) = i; break;
7643 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7648 sv_setuv_mg(argsv, (UV)i);
7649 continue; /* not "break" */
7656 if (!args && ckWARN(WARN_PRINTF) &&
7657 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7658 SV *msg = sv_newmortal();
7659 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7660 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7663 Perl_sv_catpvf(aTHX_ msg,
7664 "\"%%%c\"", c & 0xFF);
7666 Perl_sv_catpvf(aTHX_ msg,
7667 "\"%%\\%03"UVof"\"",
7670 sv_catpv(msg, "end of string");
7671 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7674 /* output mangled stuff ... */
7680 /* ... right here, because formatting flags should not apply */
7681 SvGROW(sv, SvCUR(sv) + elen + 1);
7683 Copy(eptr, p, elen, char);
7686 SvCUR(sv) = p - SvPVX(sv);
7687 continue; /* not "break" */
7690 have = esignlen + zeros + elen;
7691 need = (have > width ? have : width);
7694 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7696 if (esignlen && fill == '0') {
7697 for (i = 0; i < esignlen; i++)
7701 memset(p, fill, gap);
7704 if (esignlen && fill != '0') {
7705 for (i = 0; i < esignlen; i++)
7709 for (i = zeros; i; i--)
7713 Copy(eptr, p, elen, char);
7717 memset(p, ' ', gap);
7722 Copy(dotstr, p, dotstrlen, char);
7726 vectorize = FALSE; /* done iterating over vecstr */
7731 SvCUR(sv) = p - SvPVX(sv);
7739 #if defined(USE_ITHREADS)
7741 #if defined(USE_THREADS)
7742 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7745 #ifndef GpREFCNT_inc
7746 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7750 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7751 #define av_dup(s) (AV*)sv_dup((SV*)s)
7752 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7753 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7754 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7755 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7756 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7757 #define io_dup(s) (IO*)sv_dup((SV*)s)
7758 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7759 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7760 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7761 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7762 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7765 Perl_re_dup(pTHX_ REGEXP *r)
7767 /* XXX fix when pmop->op_pmregexp becomes shared */
7768 return ReREFCNT_inc(r);
7772 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7776 return (PerlIO*)NULL;
7778 /* look for it in the table first */
7779 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7783 /* create anew and remember what it is */
7784 ret = PerlIO_fdupopen(aTHX_ fp);
7785 ptr_table_store(PL_ptr_table, fp, ret);
7790 Perl_dirp_dup(pTHX_ DIR *dp)
7799 Perl_gp_dup(pTHX_ GP *gp)
7804 /* look for it in the table first */
7805 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7809 /* create anew and remember what it is */
7810 Newz(0, ret, 1, GP);
7811 ptr_table_store(PL_ptr_table, gp, ret);
7814 ret->gp_refcnt = 0; /* must be before any other dups! */
7815 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7816 ret->gp_io = io_dup_inc(gp->gp_io);
7817 ret->gp_form = cv_dup_inc(gp->gp_form);
7818 ret->gp_av = av_dup_inc(gp->gp_av);
7819 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7820 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7821 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7822 ret->gp_cvgen = gp->gp_cvgen;
7823 ret->gp_flags = gp->gp_flags;
7824 ret->gp_line = gp->gp_line;
7825 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7830 Perl_mg_dup(pTHX_ MAGIC *mg)
7832 MAGIC *mgprev = (MAGIC*)NULL;
7835 return (MAGIC*)NULL;
7836 /* look for it in the table first */
7837 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7841 for (; mg; mg = mg->mg_moremagic) {
7843 Newz(0, nmg, 1, MAGIC);
7845 mgprev->mg_moremagic = nmg;
7848 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7849 nmg->mg_private = mg->mg_private;
7850 nmg->mg_type = mg->mg_type;
7851 nmg->mg_flags = mg->mg_flags;
7852 if (mg->mg_type == PERL_MAGIC_qr) {
7853 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7856 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7857 ? sv_dup_inc(mg->mg_obj)
7858 : sv_dup(mg->mg_obj);
7860 nmg->mg_len = mg->mg_len;
7861 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7862 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
7863 if (mg->mg_len >= 0) {
7864 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7865 if (mg->mg_type == PERL_MAGIC_overload_table &&
7866 AMT_AMAGIC((AMT*)mg->mg_ptr))
7868 AMT *amtp = (AMT*)mg->mg_ptr;
7869 AMT *namtp = (AMT*)nmg->mg_ptr;
7871 for (i = 1; i < NofAMmeth; i++) {
7872 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7876 else if (mg->mg_len == HEf_SVKEY)
7877 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7885 Perl_ptr_table_new(pTHX)
7888 Newz(0, tbl, 1, PTR_TBL_t);
7891 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7896 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7898 PTR_TBL_ENT_t *tblent;
7899 UV hash = PTR2UV(sv);
7901 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7902 for (; tblent; tblent = tblent->next) {
7903 if (tblent->oldval == sv)
7904 return tblent->newval;
7910 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7912 PTR_TBL_ENT_t *tblent, **otblent;
7913 /* XXX this may be pessimal on platforms where pointers aren't good
7914 * hash values e.g. if they grow faster in the most significant
7916 UV hash = PTR2UV(oldv);
7920 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7921 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7922 if (tblent->oldval == oldv) {
7923 tblent->newval = newv;
7928 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7929 tblent->oldval = oldv;
7930 tblent->newval = newv;
7931 tblent->next = *otblent;
7934 if (i && tbl->tbl_items > tbl->tbl_max)
7935 ptr_table_split(tbl);
7939 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7941 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7942 UV oldsize = tbl->tbl_max + 1;
7943 UV newsize = oldsize * 2;
7946 Renew(ary, newsize, PTR_TBL_ENT_t*);
7947 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7948 tbl->tbl_max = --newsize;
7950 for (i=0; i < oldsize; i++, ary++) {
7951 PTR_TBL_ENT_t **curentp, **entp, *ent;
7954 curentp = ary + oldsize;
7955 for (entp = ary, ent = *ary; ent; ent = *entp) {
7956 if ((newsize & PTR2UV(ent->oldval)) != i) {
7958 ent->next = *curentp;
7969 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7971 register PTR_TBL_ENT_t **array;
7972 register PTR_TBL_ENT_t *entry;
7973 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7977 if (!tbl || !tbl->tbl_items) {
7981 array = tbl->tbl_ary;
7988 entry = entry->next;
7992 if (++riter > max) {
7995 entry = array[riter];
8003 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8008 ptr_table_clear(tbl);
8009 Safefree(tbl->tbl_ary);
8018 S_gv_share(pTHX_ SV *sstr)
8021 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8023 if (GvIO(gv) || GvFORM(gv)) {
8024 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8026 else if (!GvCV(gv)) {
8030 /* CvPADLISTs cannot be shared */
8031 if (!CvXSUB(GvCV(gv))) {
8036 if (!GvSHARED(gv)) {
8038 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8039 HvNAME(GvSTASH(gv)), GvNAME(gv));
8045 * write attempts will die with
8046 * "Modification of a read-only value attempted"
8052 SvREADONLY_on(GvSV(gv));
8059 SvREADONLY_on(GvAV(gv));
8066 SvREADONLY_on(GvAV(gv));
8069 return sstr; /* he_dup() will SvREFCNT_inc() */
8073 Perl_sv_dup(pTHX_ SV *sstr)
8077 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8079 /* look for it in the table first */
8080 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8084 /* create anew and remember what it is */
8086 ptr_table_store(PL_ptr_table, sstr, dstr);
8089 SvFLAGS(dstr) = SvFLAGS(sstr);
8090 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8091 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8094 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8095 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8096 PL_watch_pvx, SvPVX(sstr));
8099 switch (SvTYPE(sstr)) {
8104 SvANY(dstr) = new_XIV();
8105 SvIVX(dstr) = SvIVX(sstr);
8108 SvANY(dstr) = new_XNV();
8109 SvNVX(dstr) = SvNVX(sstr);
8112 SvANY(dstr) = new_XRV();
8113 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
8114 ? sv_dup(SvRV(sstr))
8115 : sv_dup_inc(SvRV(sstr));
8118 SvANY(dstr) = new_XPV();
8119 SvCUR(dstr) = SvCUR(sstr);
8120 SvLEN(dstr) = SvLEN(sstr);
8122 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8123 ? sv_dup(SvRV(sstr))
8124 : sv_dup_inc(SvRV(sstr));
8125 else if (SvPVX(sstr) && SvLEN(sstr))
8126 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8128 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8131 SvANY(dstr) = new_XPVIV();
8132 SvCUR(dstr) = SvCUR(sstr);
8133 SvLEN(dstr) = SvLEN(sstr);
8134 SvIVX(dstr) = SvIVX(sstr);
8136 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8137 ? sv_dup(SvRV(sstr))
8138 : sv_dup_inc(SvRV(sstr));
8139 else if (SvPVX(sstr) && SvLEN(sstr))
8140 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8142 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8145 SvANY(dstr) = new_XPVNV();
8146 SvCUR(dstr) = SvCUR(sstr);
8147 SvLEN(dstr) = SvLEN(sstr);
8148 SvIVX(dstr) = SvIVX(sstr);
8149 SvNVX(dstr) = SvNVX(sstr);
8151 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8152 ? sv_dup(SvRV(sstr))
8153 : sv_dup_inc(SvRV(sstr));
8154 else if (SvPVX(sstr) && SvLEN(sstr))
8155 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8157 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8160 SvANY(dstr) = new_XPVMG();
8161 SvCUR(dstr) = SvCUR(sstr);
8162 SvLEN(dstr) = SvLEN(sstr);
8163 SvIVX(dstr) = SvIVX(sstr);
8164 SvNVX(dstr) = SvNVX(sstr);
8165 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8166 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8168 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8169 ? sv_dup(SvRV(sstr))
8170 : sv_dup_inc(SvRV(sstr));
8171 else if (SvPVX(sstr) && SvLEN(sstr))
8172 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8174 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8177 SvANY(dstr) = new_XPVBM();
8178 SvCUR(dstr) = SvCUR(sstr);
8179 SvLEN(dstr) = SvLEN(sstr);
8180 SvIVX(dstr) = SvIVX(sstr);
8181 SvNVX(dstr) = SvNVX(sstr);
8182 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8183 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8185 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8186 ? sv_dup(SvRV(sstr))
8187 : sv_dup_inc(SvRV(sstr));
8188 else if (SvPVX(sstr) && SvLEN(sstr))
8189 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8191 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8192 BmRARE(dstr) = BmRARE(sstr);
8193 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8194 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8197 SvANY(dstr) = new_XPVLV();
8198 SvCUR(dstr) = SvCUR(sstr);
8199 SvLEN(dstr) = SvLEN(sstr);
8200 SvIVX(dstr) = SvIVX(sstr);
8201 SvNVX(dstr) = SvNVX(sstr);
8202 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8203 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8205 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8206 ? sv_dup(SvRV(sstr))
8207 : sv_dup_inc(SvRV(sstr));
8208 else if (SvPVX(sstr) && SvLEN(sstr))
8209 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8211 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8212 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8213 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8214 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8215 LvTYPE(dstr) = LvTYPE(sstr);
8218 if (GvSHARED((GV*)sstr)) {
8220 if ((share = gv_share(sstr))) {
8224 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8225 HvNAME(GvSTASH(share)), GvNAME(share));
8230 SvANY(dstr) = new_XPVGV();
8231 SvCUR(dstr) = SvCUR(sstr);
8232 SvLEN(dstr) = SvLEN(sstr);
8233 SvIVX(dstr) = SvIVX(sstr);
8234 SvNVX(dstr) = SvNVX(sstr);
8235 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8236 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8238 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8239 ? sv_dup(SvRV(sstr))
8240 : sv_dup_inc(SvRV(sstr));
8241 else if (SvPVX(sstr) && SvLEN(sstr))
8242 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8244 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8245 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8246 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8247 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8248 GvFLAGS(dstr) = GvFLAGS(sstr);
8249 GvGP(dstr) = gp_dup(GvGP(sstr));
8250 (void)GpREFCNT_inc(GvGP(dstr));
8253 SvANY(dstr) = new_XPVIO();
8254 SvCUR(dstr) = SvCUR(sstr);
8255 SvLEN(dstr) = SvLEN(sstr);
8256 SvIVX(dstr) = SvIVX(sstr);
8257 SvNVX(dstr) = SvNVX(sstr);
8258 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8259 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8261 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8262 ? sv_dup(SvRV(sstr))
8263 : sv_dup_inc(SvRV(sstr));
8264 else if (SvPVX(sstr) && SvLEN(sstr))
8265 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8267 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8268 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8269 if (IoOFP(sstr) == IoIFP(sstr))
8270 IoOFP(dstr) = IoIFP(dstr);
8272 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8273 /* PL_rsfp_filters entries have fake IoDIRP() */
8274 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8275 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8277 IoDIRP(dstr) = IoDIRP(sstr);
8278 IoLINES(dstr) = IoLINES(sstr);
8279 IoPAGE(dstr) = IoPAGE(sstr);
8280 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8281 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8282 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8283 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8284 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8285 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8286 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8287 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8288 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8289 IoTYPE(dstr) = IoTYPE(sstr);
8290 IoFLAGS(dstr) = IoFLAGS(sstr);
8293 SvANY(dstr) = new_XPVAV();
8294 SvCUR(dstr) = SvCUR(sstr);
8295 SvLEN(dstr) = SvLEN(sstr);
8296 SvIVX(dstr) = SvIVX(sstr);
8297 SvNVX(dstr) = SvNVX(sstr);
8298 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8299 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8300 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8301 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8302 if (AvARRAY((AV*)sstr)) {
8303 SV **dst_ary, **src_ary;
8304 SSize_t items = AvFILLp((AV*)sstr) + 1;
8306 src_ary = AvARRAY((AV*)sstr);
8307 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8308 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8309 SvPVX(dstr) = (char*)dst_ary;
8310 AvALLOC((AV*)dstr) = dst_ary;
8311 if (AvREAL((AV*)sstr)) {
8313 *dst_ary++ = sv_dup_inc(*src_ary++);
8317 *dst_ary++ = sv_dup(*src_ary++);
8319 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8320 while (items-- > 0) {
8321 *dst_ary++ = &PL_sv_undef;
8325 SvPVX(dstr) = Nullch;
8326 AvALLOC((AV*)dstr) = (SV**)NULL;
8330 SvANY(dstr) = new_XPVHV();
8331 SvCUR(dstr) = SvCUR(sstr);
8332 SvLEN(dstr) = SvLEN(sstr);
8333 SvIVX(dstr) = SvIVX(sstr);
8334 SvNVX(dstr) = SvNVX(sstr);
8335 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8336 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8337 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8338 if (HvARRAY((HV*)sstr)) {
8340 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8341 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8342 Newz(0, dxhv->xhv_array,
8343 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8344 while (i <= sxhv->xhv_max) {
8345 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8346 !!HvSHAREKEYS(sstr));
8349 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8352 SvPVX(dstr) = Nullch;
8353 HvEITER((HV*)dstr) = (HE*)NULL;
8355 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8356 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8359 SvANY(dstr) = new_XPVFM();
8360 FmLINES(dstr) = FmLINES(sstr);
8364 SvANY(dstr) = new_XPVCV();
8366 SvCUR(dstr) = SvCUR(sstr);
8367 SvLEN(dstr) = SvLEN(sstr);
8368 SvIVX(dstr) = SvIVX(sstr);
8369 SvNVX(dstr) = SvNVX(sstr);
8370 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8371 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8372 if (SvPVX(sstr) && SvLEN(sstr))
8373 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8375 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8376 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8377 CvSTART(dstr) = CvSTART(sstr);
8378 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8379 CvXSUB(dstr) = CvXSUB(sstr);
8380 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8381 CvGV(dstr) = gv_dup(CvGV(sstr));
8382 CvDEPTH(dstr) = CvDEPTH(sstr);
8383 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8384 /* XXX padlists are real, but pretend to be not */
8385 AvREAL_on(CvPADLIST(sstr));
8386 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8387 AvREAL_off(CvPADLIST(sstr));
8388 AvREAL_off(CvPADLIST(dstr));
8391 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8392 if (!CvANON(sstr) || CvCLONED(sstr))
8393 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8395 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8396 CvFLAGS(dstr) = CvFLAGS(sstr);
8399 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8403 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8410 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8415 return (PERL_CONTEXT*)NULL;
8417 /* look for it in the table first */
8418 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8422 /* create anew and remember what it is */
8423 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8424 ptr_table_store(PL_ptr_table, cxs, ncxs);
8427 PERL_CONTEXT *cx = &cxs[ix];
8428 PERL_CONTEXT *ncx = &ncxs[ix];
8429 ncx->cx_type = cx->cx_type;
8430 if (CxTYPE(cx) == CXt_SUBST) {
8431 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8434 ncx->blk_oldsp = cx->blk_oldsp;
8435 ncx->blk_oldcop = cx->blk_oldcop;
8436 ncx->blk_oldretsp = cx->blk_oldretsp;
8437 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8438 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8439 ncx->blk_oldpm = cx->blk_oldpm;
8440 ncx->blk_gimme = cx->blk_gimme;
8441 switch (CxTYPE(cx)) {
8443 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8444 ? cv_dup_inc(cx->blk_sub.cv)
8445 : cv_dup(cx->blk_sub.cv));
8446 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8447 ? av_dup_inc(cx->blk_sub.argarray)
8449 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8450 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8451 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8452 ncx->blk_sub.lval = cx->blk_sub.lval;
8455 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8456 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8457 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8458 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8459 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8462 ncx->blk_loop.label = cx->blk_loop.label;
8463 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8464 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8465 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8466 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8467 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8468 ? cx->blk_loop.iterdata
8469 : gv_dup((GV*)cx->blk_loop.iterdata));
8470 ncx->blk_loop.oldcurpad
8471 = (SV**)ptr_table_fetch(PL_ptr_table,
8472 cx->blk_loop.oldcurpad);
8473 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8474 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8475 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8476 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8477 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8480 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8481 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8482 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8483 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8496 Perl_si_dup(pTHX_ PERL_SI *si)
8501 return (PERL_SI*)NULL;
8503 /* look for it in the table first */
8504 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8508 /* create anew and remember what it is */
8509 Newz(56, nsi, 1, PERL_SI);
8510 ptr_table_store(PL_ptr_table, si, nsi);
8512 nsi->si_stack = av_dup_inc(si->si_stack);
8513 nsi->si_cxix = si->si_cxix;
8514 nsi->si_cxmax = si->si_cxmax;
8515 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8516 nsi->si_type = si->si_type;
8517 nsi->si_prev = si_dup(si->si_prev);
8518 nsi->si_next = si_dup(si->si_next);
8519 nsi->si_markoff = si->si_markoff;
8524 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8525 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8526 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8527 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8528 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8529 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8530 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8531 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8532 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8533 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8534 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8535 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8538 #define pv_dup_inc(p) SAVEPV(p)
8539 #define pv_dup(p) SAVEPV(p)
8540 #define svp_dup_inc(p,pp) any_dup(p,pp)
8543 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8550 /* look for it in the table first */
8551 ret = ptr_table_fetch(PL_ptr_table, v);
8555 /* see if it is part of the interpreter structure */
8556 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8557 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8565 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8567 ANY *ss = proto_perl->Tsavestack;
8568 I32 ix = proto_perl->Tsavestack_ix;
8569 I32 max = proto_perl->Tsavestack_max;
8582 void (*dptr) (void*);
8583 void (*dxptr) (pTHXo_ void*);
8586 Newz(54, nss, max, ANY);
8592 case SAVEt_ITEM: /* normal string */
8593 sv = (SV*)POPPTR(ss,ix);
8594 TOPPTR(nss,ix) = sv_dup_inc(sv);
8595 sv = (SV*)POPPTR(ss,ix);
8596 TOPPTR(nss,ix) = sv_dup_inc(sv);
8598 case SAVEt_SV: /* scalar reference */
8599 sv = (SV*)POPPTR(ss,ix);
8600 TOPPTR(nss,ix) = sv_dup_inc(sv);
8601 gv = (GV*)POPPTR(ss,ix);
8602 TOPPTR(nss,ix) = gv_dup_inc(gv);
8604 case SAVEt_GENERIC_PVREF: /* generic char* */
8605 c = (char*)POPPTR(ss,ix);
8606 TOPPTR(nss,ix) = pv_dup(c);
8607 ptr = POPPTR(ss,ix);
8608 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8610 case SAVEt_GENERIC_SVREF: /* generic sv */
8611 case SAVEt_SVREF: /* scalar reference */
8612 sv = (SV*)POPPTR(ss,ix);
8613 TOPPTR(nss,ix) = sv_dup_inc(sv);
8614 ptr = POPPTR(ss,ix);
8615 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8617 case SAVEt_AV: /* array reference */
8618 av = (AV*)POPPTR(ss,ix);
8619 TOPPTR(nss,ix) = av_dup_inc(av);
8620 gv = (GV*)POPPTR(ss,ix);
8621 TOPPTR(nss,ix) = gv_dup(gv);
8623 case SAVEt_HV: /* hash reference */
8624 hv = (HV*)POPPTR(ss,ix);
8625 TOPPTR(nss,ix) = hv_dup_inc(hv);
8626 gv = (GV*)POPPTR(ss,ix);
8627 TOPPTR(nss,ix) = gv_dup(gv);
8629 case SAVEt_INT: /* int reference */
8630 ptr = POPPTR(ss,ix);
8631 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8632 intval = (int)POPINT(ss,ix);
8633 TOPINT(nss,ix) = intval;
8635 case SAVEt_LONG: /* long reference */
8636 ptr = POPPTR(ss,ix);
8637 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8638 longval = (long)POPLONG(ss,ix);
8639 TOPLONG(nss,ix) = longval;
8641 case SAVEt_I32: /* I32 reference */
8642 case SAVEt_I16: /* I16 reference */
8643 case SAVEt_I8: /* I8 reference */
8644 ptr = POPPTR(ss,ix);
8645 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8649 case SAVEt_IV: /* IV reference */
8650 ptr = POPPTR(ss,ix);
8651 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8655 case SAVEt_SPTR: /* SV* reference */
8656 ptr = POPPTR(ss,ix);
8657 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8658 sv = (SV*)POPPTR(ss,ix);
8659 TOPPTR(nss,ix) = sv_dup(sv);
8661 case SAVEt_VPTR: /* random* reference */
8662 ptr = POPPTR(ss,ix);
8663 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8664 ptr = POPPTR(ss,ix);
8665 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8667 case SAVEt_PPTR: /* char* reference */
8668 ptr = POPPTR(ss,ix);
8669 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8670 c = (char*)POPPTR(ss,ix);
8671 TOPPTR(nss,ix) = pv_dup(c);
8673 case SAVEt_HPTR: /* HV* reference */
8674 ptr = POPPTR(ss,ix);
8675 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8676 hv = (HV*)POPPTR(ss,ix);
8677 TOPPTR(nss,ix) = hv_dup(hv);
8679 case SAVEt_APTR: /* AV* reference */
8680 ptr = POPPTR(ss,ix);
8681 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8682 av = (AV*)POPPTR(ss,ix);
8683 TOPPTR(nss,ix) = av_dup(av);
8686 gv = (GV*)POPPTR(ss,ix);
8687 TOPPTR(nss,ix) = gv_dup(gv);
8689 case SAVEt_GP: /* scalar reference */
8690 gp = (GP*)POPPTR(ss,ix);
8691 TOPPTR(nss,ix) = gp = gp_dup(gp);
8692 (void)GpREFCNT_inc(gp);
8693 gv = (GV*)POPPTR(ss,ix);
8694 TOPPTR(nss,ix) = gv_dup_inc(c);
8695 c = (char*)POPPTR(ss,ix);
8696 TOPPTR(nss,ix) = pv_dup(c);
8703 case SAVEt_MORTALIZESV:
8704 sv = (SV*)POPPTR(ss,ix);
8705 TOPPTR(nss,ix) = sv_dup_inc(sv);
8708 ptr = POPPTR(ss,ix);
8709 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8710 /* these are assumed to be refcounted properly */
8711 switch (((OP*)ptr)->op_type) {
8718 TOPPTR(nss,ix) = ptr;
8723 TOPPTR(nss,ix) = Nullop;
8728 TOPPTR(nss,ix) = Nullop;
8731 c = (char*)POPPTR(ss,ix);
8732 TOPPTR(nss,ix) = pv_dup_inc(c);
8735 longval = POPLONG(ss,ix);
8736 TOPLONG(nss,ix) = longval;
8739 hv = (HV*)POPPTR(ss,ix);
8740 TOPPTR(nss,ix) = hv_dup_inc(hv);
8741 c = (char*)POPPTR(ss,ix);
8742 TOPPTR(nss,ix) = pv_dup_inc(c);
8746 case SAVEt_DESTRUCTOR:
8747 ptr = POPPTR(ss,ix);
8748 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8749 dptr = POPDPTR(ss,ix);
8750 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8752 case SAVEt_DESTRUCTOR_X:
8753 ptr = POPPTR(ss,ix);
8754 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8755 dxptr = POPDXPTR(ss,ix);
8756 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8758 case SAVEt_REGCONTEXT:
8764 case SAVEt_STACK_POS: /* Position on Perl stack */
8768 case SAVEt_AELEM: /* array element */
8769 sv = (SV*)POPPTR(ss,ix);
8770 TOPPTR(nss,ix) = sv_dup_inc(sv);
8773 av = (AV*)POPPTR(ss,ix);
8774 TOPPTR(nss,ix) = av_dup_inc(av);
8776 case SAVEt_HELEM: /* hash element */
8777 sv = (SV*)POPPTR(ss,ix);
8778 TOPPTR(nss,ix) = sv_dup_inc(sv);
8779 sv = (SV*)POPPTR(ss,ix);
8780 TOPPTR(nss,ix) = sv_dup_inc(sv);
8781 hv = (HV*)POPPTR(ss,ix);
8782 TOPPTR(nss,ix) = hv_dup_inc(hv);
8785 ptr = POPPTR(ss,ix);
8786 TOPPTR(nss,ix) = ptr;
8793 av = (AV*)POPPTR(ss,ix);
8794 TOPPTR(nss,ix) = av_dup(av);
8797 longval = (long)POPLONG(ss,ix);
8798 TOPLONG(nss,ix) = longval;
8799 ptr = POPPTR(ss,ix);
8800 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8801 sv = (SV*)POPPTR(ss,ix);
8802 TOPPTR(nss,ix) = sv_dup(sv);
8805 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8817 perl_clone(PerlInterpreter *proto_perl, UV flags)
8820 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8823 #ifdef PERL_IMPLICIT_SYS
8824 return perl_clone_using(proto_perl, flags,
8826 proto_perl->IMemShared,
8827 proto_perl->IMemParse,
8837 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8838 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8839 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8840 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8841 struct IPerlDir* ipD, struct IPerlSock* ipS,
8842 struct IPerlProc* ipP)
8844 /* XXX many of the string copies here can be optimized if they're
8845 * constants; they need to be allocated as common memory and just
8846 * their pointers copied. */
8850 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8852 PERL_SET_THX(pPerl);
8853 # else /* !PERL_OBJECT */
8854 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8855 PERL_SET_THX(my_perl);
8858 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8864 # else /* !DEBUGGING */
8865 Zero(my_perl, 1, PerlInterpreter);
8866 # endif /* DEBUGGING */
8870 PL_MemShared = ipMS;
8878 # endif /* PERL_OBJECT */
8879 #else /* !PERL_IMPLICIT_SYS */
8881 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8882 PERL_SET_THX(my_perl);
8885 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8891 # else /* !DEBUGGING */
8892 Zero(my_perl, 1, PerlInterpreter);
8893 # endif /* DEBUGGING */
8894 #endif /* PERL_IMPLICIT_SYS */
8897 PL_xiv_arenaroot = NULL;
8899 PL_xnv_arenaroot = NULL;
8901 PL_xrv_arenaroot = NULL;
8903 PL_xpv_arenaroot = NULL;
8905 PL_xpviv_arenaroot = NULL;
8906 PL_xpviv_root = NULL;
8907 PL_xpvnv_arenaroot = NULL;
8908 PL_xpvnv_root = NULL;
8909 PL_xpvcv_arenaroot = NULL;
8910 PL_xpvcv_root = NULL;
8911 PL_xpvav_arenaroot = NULL;
8912 PL_xpvav_root = NULL;
8913 PL_xpvhv_arenaroot = NULL;
8914 PL_xpvhv_root = NULL;
8915 PL_xpvmg_arenaroot = NULL;
8916 PL_xpvmg_root = NULL;
8917 PL_xpvlv_arenaroot = NULL;
8918 PL_xpvlv_root = NULL;
8919 PL_xpvbm_arenaroot = NULL;
8920 PL_xpvbm_root = NULL;
8921 PL_he_arenaroot = NULL;
8923 PL_nice_chunk = NULL;
8924 PL_nice_chunk_size = 0;
8927 PL_sv_root = Nullsv;
8928 PL_sv_arenaroot = Nullsv;
8930 PL_debug = proto_perl->Idebug;
8932 /* create SV map for pointer relocation */
8933 PL_ptr_table = ptr_table_new();
8935 /* initialize these special pointers as early as possible */
8936 SvANY(&PL_sv_undef) = NULL;
8937 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8938 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8939 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8942 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8944 SvANY(&PL_sv_no) = new_XPVNV();
8946 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8947 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8948 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8949 SvCUR(&PL_sv_no) = 0;
8950 SvLEN(&PL_sv_no) = 1;
8951 SvNVX(&PL_sv_no) = 0;
8952 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8955 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8957 SvANY(&PL_sv_yes) = new_XPVNV();
8959 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8960 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8961 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8962 SvCUR(&PL_sv_yes) = 1;
8963 SvLEN(&PL_sv_yes) = 2;
8964 SvNVX(&PL_sv_yes) = 1;
8965 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8967 /* create shared string table */
8968 PL_strtab = newHV();
8969 HvSHAREKEYS_off(PL_strtab);
8970 hv_ksplit(PL_strtab, 512);
8971 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8973 PL_compiling = proto_perl->Icompiling;
8974 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8975 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8976 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8977 if (!specialWARN(PL_compiling.cop_warnings))
8978 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8979 if (!specialCopIO(PL_compiling.cop_io))
8980 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8981 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8983 /* pseudo environmental stuff */
8984 PL_origargc = proto_perl->Iorigargc;
8986 New(0, PL_origargv, i+1, char*);
8987 PL_origargv[i] = '\0';
8989 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8991 PL_envgv = gv_dup(proto_perl->Ienvgv);
8992 PL_incgv = gv_dup(proto_perl->Iincgv);
8993 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8994 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8995 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8996 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8999 PL_minus_c = proto_perl->Iminus_c;
9000 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
9001 PL_localpatches = proto_perl->Ilocalpatches;
9002 PL_splitstr = proto_perl->Isplitstr;
9003 PL_preprocess = proto_perl->Ipreprocess;
9004 PL_minus_n = proto_perl->Iminus_n;
9005 PL_minus_p = proto_perl->Iminus_p;
9006 PL_minus_l = proto_perl->Iminus_l;
9007 PL_minus_a = proto_perl->Iminus_a;
9008 PL_minus_F = proto_perl->Iminus_F;
9009 PL_doswitches = proto_perl->Idoswitches;
9010 PL_dowarn = proto_perl->Idowarn;
9011 PL_doextract = proto_perl->Idoextract;
9012 PL_sawampersand = proto_perl->Isawampersand;
9013 PL_unsafe = proto_perl->Iunsafe;
9014 PL_inplace = SAVEPV(proto_perl->Iinplace);
9015 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
9016 PL_perldb = proto_perl->Iperldb;
9017 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9019 /* magical thingies */
9020 /* XXX time(&PL_basetime) when asked for? */
9021 PL_basetime = proto_perl->Ibasetime;
9022 PL_formfeed = sv_dup(proto_perl->Iformfeed);
9024 PL_maxsysfd = proto_perl->Imaxsysfd;
9025 PL_multiline = proto_perl->Imultiline;
9026 PL_statusvalue = proto_perl->Istatusvalue;
9028 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9031 /* shortcuts to various I/O objects */
9032 PL_stdingv = gv_dup(proto_perl->Istdingv);
9033 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
9034 PL_defgv = gv_dup(proto_perl->Idefgv);
9035 PL_argvgv = gv_dup(proto_perl->Iargvgv);
9036 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
9037 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
9039 /* shortcuts to regexp stuff */
9040 PL_replgv = gv_dup(proto_perl->Ireplgv);
9042 /* shortcuts to misc objects */
9043 PL_errgv = gv_dup(proto_perl->Ierrgv);
9045 /* shortcuts to debugging objects */
9046 PL_DBgv = gv_dup(proto_perl->IDBgv);
9047 PL_DBline = gv_dup(proto_perl->IDBline);
9048 PL_DBsub = gv_dup(proto_perl->IDBsub);
9049 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
9050 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
9051 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
9052 PL_lineary = av_dup(proto_perl->Ilineary);
9053 PL_dbargs = av_dup(proto_perl->Idbargs);
9056 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
9057 PL_curstash = hv_dup(proto_perl->Tcurstash);
9058 PL_debstash = hv_dup(proto_perl->Idebstash);
9059 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
9060 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
9062 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
9063 PL_endav = av_dup_inc(proto_perl->Iendav);
9064 PL_checkav = av_dup_inc(proto_perl->Icheckav);
9065 PL_initav = av_dup_inc(proto_perl->Iinitav);
9067 PL_sub_generation = proto_perl->Isub_generation;
9069 /* funky return mechanisms */
9070 PL_forkprocess = proto_perl->Iforkprocess;
9072 /* subprocess state */
9073 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
9075 /* internal state */
9076 PL_tainting = proto_perl->Itainting;
9077 PL_maxo = proto_perl->Imaxo;
9078 if (proto_perl->Iop_mask)
9079 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9081 PL_op_mask = Nullch;
9083 /* current interpreter roots */
9084 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
9085 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9086 PL_main_start = proto_perl->Imain_start;
9087 PL_eval_root = proto_perl->Ieval_root;
9088 PL_eval_start = proto_perl->Ieval_start;
9090 /* runtime control stuff */
9091 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9092 PL_copline = proto_perl->Icopline;
9094 PL_filemode = proto_perl->Ifilemode;
9095 PL_lastfd = proto_perl->Ilastfd;
9096 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9099 PL_gensym = proto_perl->Igensym;
9100 PL_preambled = proto_perl->Ipreambled;
9101 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
9102 PL_laststatval = proto_perl->Ilaststatval;
9103 PL_laststype = proto_perl->Ilaststype;
9104 PL_mess_sv = Nullsv;
9106 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
9107 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9109 /* interpreter atexit processing */
9110 PL_exitlistlen = proto_perl->Iexitlistlen;
9111 if (PL_exitlistlen) {
9112 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9113 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9116 PL_exitlist = (PerlExitListEntry*)NULL;
9117 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
9119 PL_profiledata = NULL;
9120 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
9121 /* PL_rsfp_filters entries have fake IoDIRP() */
9122 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
9124 PL_compcv = cv_dup(proto_perl->Icompcv);
9125 PL_comppad = av_dup(proto_perl->Icomppad);
9126 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
9127 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9128 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9129 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9130 proto_perl->Tcurpad);
9132 #ifdef HAVE_INTERP_INTERN
9133 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9136 /* more statics moved here */
9137 PL_generation = proto_perl->Igeneration;
9138 PL_DBcv = cv_dup(proto_perl->IDBcv);
9140 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9141 PL_in_clean_all = proto_perl->Iin_clean_all;
9143 PL_uid = proto_perl->Iuid;
9144 PL_euid = proto_perl->Ieuid;
9145 PL_gid = proto_perl->Igid;
9146 PL_egid = proto_perl->Iegid;
9147 PL_nomemok = proto_perl->Inomemok;
9148 PL_an = proto_perl->Ian;
9149 PL_cop_seqmax = proto_perl->Icop_seqmax;
9150 PL_op_seqmax = proto_perl->Iop_seqmax;
9151 PL_evalseq = proto_perl->Ievalseq;
9152 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9153 PL_origalen = proto_perl->Iorigalen;
9154 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9155 PL_osname = SAVEPV(proto_perl->Iosname);
9156 PL_sh_path = SAVEPV(proto_perl->Ish_path);
9157 PL_sighandlerp = proto_perl->Isighandlerp;
9160 PL_runops = proto_perl->Irunops;
9162 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9165 PL_cshlen = proto_perl->Icshlen;
9166 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9169 PL_lex_state = proto_perl->Ilex_state;
9170 PL_lex_defer = proto_perl->Ilex_defer;
9171 PL_lex_expect = proto_perl->Ilex_expect;
9172 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9173 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9174 PL_lex_starts = proto_perl->Ilex_starts;
9175 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
9176 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
9177 PL_lex_op = proto_perl->Ilex_op;
9178 PL_lex_inpat = proto_perl->Ilex_inpat;
9179 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9180 PL_lex_brackets = proto_perl->Ilex_brackets;
9181 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9182 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9183 PL_lex_casemods = proto_perl->Ilex_casemods;
9184 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9185 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9187 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9188 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9189 PL_nexttoke = proto_perl->Inexttoke;
9191 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9192 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9193 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9194 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9195 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9196 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9197 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9198 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9199 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9200 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9201 PL_pending_ident = proto_perl->Ipending_ident;
9202 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9204 PL_expect = proto_perl->Iexpect;
9206 PL_multi_start = proto_perl->Imulti_start;
9207 PL_multi_end = proto_perl->Imulti_end;
9208 PL_multi_open = proto_perl->Imulti_open;
9209 PL_multi_close = proto_perl->Imulti_close;
9211 PL_error_count = proto_perl->Ierror_count;
9212 PL_subline = proto_perl->Isubline;
9213 PL_subname = sv_dup_inc(proto_perl->Isubname);
9215 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9216 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9217 PL_padix = proto_perl->Ipadix;
9218 PL_padix_floor = proto_perl->Ipadix_floor;
9219 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9221 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9222 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9223 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9224 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9225 PL_last_lop_op = proto_perl->Ilast_lop_op;
9226 PL_in_my = proto_perl->Iin_my;
9227 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9229 PL_cryptseen = proto_perl->Icryptseen;
9232 PL_hints = proto_perl->Ihints;
9234 PL_amagic_generation = proto_perl->Iamagic_generation;
9236 #ifdef USE_LOCALE_COLLATE
9237 PL_collation_ix = proto_perl->Icollation_ix;
9238 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9239 PL_collation_standard = proto_perl->Icollation_standard;
9240 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9241 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9242 #endif /* USE_LOCALE_COLLATE */
9244 #ifdef USE_LOCALE_NUMERIC
9245 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9246 PL_numeric_standard = proto_perl->Inumeric_standard;
9247 PL_numeric_local = proto_perl->Inumeric_local;
9248 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
9249 #endif /* !USE_LOCALE_NUMERIC */
9251 /* utf8 character classes */
9252 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9253 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9254 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9255 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9256 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9257 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9258 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9259 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9260 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9261 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9262 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9263 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9264 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9265 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9266 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9267 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9268 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9271 PL_last_swash_hv = Nullhv; /* reinits on demand */
9272 PL_last_swash_klen = 0;
9273 PL_last_swash_key[0]= '\0';
9274 PL_last_swash_tmps = (U8*)NULL;
9275 PL_last_swash_slen = 0;
9277 /* perly.c globals */
9278 PL_yydebug = proto_perl->Iyydebug;
9279 PL_yynerrs = proto_perl->Iyynerrs;
9280 PL_yyerrflag = proto_perl->Iyyerrflag;
9281 PL_yychar = proto_perl->Iyychar;
9282 PL_yyval = proto_perl->Iyyval;
9283 PL_yylval = proto_perl->Iyylval;
9285 PL_glob_index = proto_perl->Iglob_index;
9286 PL_srand_called = proto_perl->Isrand_called;
9287 PL_uudmap['M'] = 0; /* reinits on demand */
9288 PL_bitcount = Nullch; /* reinits on demand */
9290 if (proto_perl->Ipsig_pend) {
9291 Newz(0, PL_psig_pend, SIG_SIZE, int);
9294 PL_psig_pend = (int*)NULL;
9297 if (proto_perl->Ipsig_ptr) {
9298 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9299 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9300 for (i = 1; i < SIG_SIZE; i++) {
9301 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9302 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9306 PL_psig_ptr = (SV**)NULL;
9307 PL_psig_name = (SV**)NULL;
9310 /* thrdvar.h stuff */
9312 if (flags & CLONEf_COPY_STACKS) {
9313 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9314 PL_tmps_ix = proto_perl->Ttmps_ix;
9315 PL_tmps_max = proto_perl->Ttmps_max;
9316 PL_tmps_floor = proto_perl->Ttmps_floor;
9317 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9319 while (i <= PL_tmps_ix) {
9320 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9324 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9325 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9326 Newz(54, PL_markstack, i, I32);
9327 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9328 - proto_perl->Tmarkstack);
9329 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9330 - proto_perl->Tmarkstack);
9331 Copy(proto_perl->Tmarkstack, PL_markstack,
9332 PL_markstack_ptr - PL_markstack + 1, I32);
9334 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9335 * NOTE: unlike the others! */
9336 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9337 PL_scopestack_max = proto_perl->Tscopestack_max;
9338 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9339 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9341 /* next push_return() sets PL_retstack[PL_retstack_ix]
9342 * NOTE: unlike the others! */
9343 PL_retstack_ix = proto_perl->Tretstack_ix;
9344 PL_retstack_max = proto_perl->Tretstack_max;
9345 Newz(54, PL_retstack, PL_retstack_max, OP*);
9346 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9348 /* NOTE: si_dup() looks at PL_markstack */
9349 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9351 /* PL_curstack = PL_curstackinfo->si_stack; */
9352 PL_curstack = av_dup(proto_perl->Tcurstack);
9353 PL_mainstack = av_dup(proto_perl->Tmainstack);
9355 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9356 PL_stack_base = AvARRAY(PL_curstack);
9357 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9358 - proto_perl->Tstack_base);
9359 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9361 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9362 * NOTE: unlike the others! */
9363 PL_savestack_ix = proto_perl->Tsavestack_ix;
9364 PL_savestack_max = proto_perl->Tsavestack_max;
9365 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9366 PL_savestack = ss_dup(proto_perl);
9370 ENTER; /* perl_destruct() wants to LEAVE; */
9373 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9374 PL_top_env = &PL_start_env;
9376 PL_op = proto_perl->Top;
9379 PL_Xpv = (XPV*)NULL;
9380 PL_na = proto_perl->Tna;
9382 PL_statbuf = proto_perl->Tstatbuf;
9383 PL_statcache = proto_perl->Tstatcache;
9384 PL_statgv = gv_dup(proto_perl->Tstatgv);
9385 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9387 PL_timesbuf = proto_perl->Ttimesbuf;
9390 PL_tainted = proto_perl->Ttainted;
9391 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9392 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9393 PL_rs = sv_dup_inc(proto_perl->Trs);
9394 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9395 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9396 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9397 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9398 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9399 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9400 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9402 PL_restartop = proto_perl->Trestartop;
9403 PL_in_eval = proto_perl->Tin_eval;
9404 PL_delaymagic = proto_perl->Tdelaymagic;
9405 PL_dirty = proto_perl->Tdirty;
9406 PL_localizing = proto_perl->Tlocalizing;
9408 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9409 PL_protect = proto_perl->Tprotect;
9411 PL_errors = sv_dup_inc(proto_perl->Terrors);
9412 PL_av_fetch_sv = Nullsv;
9413 PL_hv_fetch_sv = Nullsv;
9414 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9415 PL_modcount = proto_perl->Tmodcount;
9416 PL_lastgotoprobe = Nullop;
9417 PL_dumpindent = proto_perl->Tdumpindent;
9419 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9420 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9421 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9422 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9423 PL_sortcxix = proto_perl->Tsortcxix;
9424 PL_efloatbuf = Nullch; /* reinits on demand */
9425 PL_efloatsize = 0; /* reinits on demand */
9429 PL_screamfirst = NULL;
9430 PL_screamnext = NULL;
9431 PL_maxscream = -1; /* reinits on demand */
9432 PL_lastscream = Nullsv;
9434 PL_watchaddr = NULL;
9435 PL_watchok = Nullch;
9437 PL_regdummy = proto_perl->Tregdummy;
9438 PL_regcomp_parse = Nullch;
9439 PL_regxend = Nullch;
9440 PL_regcode = (regnode*)NULL;
9443 PL_regprecomp = Nullch;
9448 PL_seen_zerolen = 0;
9450 PL_regcomp_rx = (regexp*)NULL;
9452 PL_colorset = 0; /* reinits PL_colors[] */
9453 /*PL_colors[6] = {0,0,0,0,0,0};*/
9454 PL_reg_whilem_seen = 0;
9455 PL_reginput = Nullch;
9458 PL_regstartp = (I32*)NULL;
9459 PL_regendp = (I32*)NULL;
9460 PL_reglastparen = (U32*)NULL;
9461 PL_regtill = Nullch;
9462 PL_reg_start_tmp = (char**)NULL;
9463 PL_reg_start_tmpl = 0;
9464 PL_regdata = (struct reg_data*)NULL;
9467 PL_reg_eval_set = 0;
9469 PL_regprogram = (regnode*)NULL;
9471 PL_regcc = (CURCUR*)NULL;
9472 PL_reg_call_cc = (struct re_cc_state*)NULL;
9473 PL_reg_re = (regexp*)NULL;
9474 PL_reg_ganch = Nullch;
9476 PL_reg_magic = (MAGIC*)NULL;
9478 PL_reg_oldcurpm = (PMOP*)NULL;
9479 PL_reg_curpm = (PMOP*)NULL;
9480 PL_reg_oldsaved = Nullch;
9481 PL_reg_oldsavedlen = 0;
9483 PL_reg_leftiter = 0;
9484 PL_reg_poscache = Nullch;
9485 PL_reg_poscache_size= 0;
9487 /* RE engine - function pointers */
9488 PL_regcompp = proto_perl->Tregcompp;
9489 PL_regexecp = proto_perl->Tregexecp;
9490 PL_regint_start = proto_perl->Tregint_start;
9491 PL_regint_string = proto_perl->Tregint_string;
9492 PL_regfree = proto_perl->Tregfree;
9494 PL_reginterp_cnt = 0;
9495 PL_reg_starttry = 0;
9497 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9498 ptr_table_free(PL_ptr_table);
9499 PL_ptr_table = NULL;
9503 return (PerlInterpreter*)pPerl;
9509 #else /* !USE_ITHREADS */
9515 #endif /* USE_ITHREADS */
9518 do_report_used(pTHXo_ SV *sv)
9520 if (SvTYPE(sv) != SVTYPEMASK) {
9521 PerlIO_printf(Perl_debug_log, "****\n");
9527 do_clean_objs(pTHXo_ SV *sv)
9531 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9532 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
9533 if (SvWEAKREF(sv)) {
9544 /* XXX Might want to check arrays, etc. */
9547 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9549 do_clean_named_objs(pTHXo_ SV *sv)
9551 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9552 if ( SvOBJECT(GvSV(sv)) ||
9553 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9554 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9555 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9556 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9558 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
9566 do_clean_all(pTHXo_ SV *sv)
9568 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
9569 SvFLAGS(sv) |= SVf_BREAK;