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_numeric_radix(pTHX_ const char **sp, const char *send)
1500 #ifdef USE_LOCALE_NUMERIC
1501 if (PL_numeric_radix_sv && IN_LOCALE) {
1503 char* radix = SvPV(PL_numeric_radix_sv, len);
1504 if (*sp + len <= send && memEQ(*sp, radix, len)) {
1509 /* always try "." if numeric radix didn't match because
1510 * we may have data from different locales mixed */
1512 if (*sp < send && **sp == '.') {
1519 #define GROK_NUMERIC_RADIX(sp, send) grok_numeric_radix(sp, send)
1522 S_grok_number(pTHX_ const char *pv, STRLEN len, UV *valuep)
1525 const char *send = pv + len;
1526 const UV max_div_10 = UV_MAX / 10;
1527 const char max_mod_10 = UV_MAX % 10 + '0';
1535 numtype = IS_NUMBER_NEG;
1540 /* next must be digit or the radix separator or beginning of infinity */
1542 /* UVs are at least 32 bits, so the first 9 decimal digits cannot
1544 UV value = *s - '0';
1545 /* This construction seems to be more optimiser friendly.
1546 (without it gcc does the isDIGIT test and the *s - '0' separately)
1547 With it gcc on arm is managing 6 instructions (6 cycles) per digit.
1548 In theory the optimiser could deduce how far to unroll the loop
1549 before checking for overflow. */
1550 int digit = *++s - '0';
1551 if (digit >= 0 && digit <= 9) {
1552 value = value * 10 + digit;
1554 if (digit >= 0 && digit <= 9) {
1555 value = value * 10 + digit;
1557 if (digit >= 0 && digit <= 9) {
1558 value = value * 10 + digit;
1560 if (digit >= 0 && digit <= 9) {
1561 value = value * 10 + digit;
1563 if (digit >= 0 && digit <= 9) {
1564 value = value * 10 + digit;
1566 if (digit >= 0 && digit <= 9) {
1567 value = value * 10 + digit;
1569 if (digit >= 0 && digit <= 9) {
1570 value = value * 10 + digit;
1572 if (digit >= 0 && digit <= 9) {
1573 value = value * 10 + digit;
1574 /* Now got 9 digits, so need to check
1575 each time for overflow. */
1577 while (digit >= 0 && digit <= 9
1578 && (value < max_div_10
1579 || (value == max_div_10
1580 && *s <= max_mod_10))) {
1581 value = value * 10 + digit;
1584 if (digit >= 0 && digit <= 9) {
1585 /* value overflowed.
1586 skip the remaining digits, don't
1587 worry about setting *valuep. */
1590 } while (isDIGIT(*s));
1592 IS_NUMBER_GREATER_THAN_UV_MAX;
1603 numtype |= IS_NUMBER_IN_UV;
1608 if (GROK_NUMERIC_RADIX(&s, send)) {
1609 numtype |= IS_NUMBER_NOT_INT;
1610 while (isDIGIT(*s)) /* optional digits after the radix */
1614 else if (GROK_NUMERIC_RADIX(&s, send)) {
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
2074 assert (SvIOKp(sv));
2076 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2077 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2078 /* Small enough to preserve all bits. */
2079 (void)SvIOKp_on(sv);
2081 SvIVX(sv) = I_V(SvNVX(sv));
2082 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2084 /* Assumption: first non-preserved integer is < IV_MAX,
2085 this NV is in the preserved range, therefore: */
2086 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2088 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);
2092 0 0 already failed to read UV.
2093 0 1 already failed to read UV.
2094 1 0 you won't get here in this case. IV/UV
2095 slot set, public IOK, Atof() unneeded.
2096 1 1 already read UV.
2097 so there's no point in sv_2iuv_non_preserve() attempting
2098 to use atol, strtol, strtoul etc. */
2099 if (sv_2iuv_non_preserve (sv, numtype)
2100 >= IS_NUMBER_OVERFLOW_IV)
2104 #endif /* NV_PRESERVES_UV */
2107 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2109 if (SvTYPE(sv) < SVt_IV)
2110 /* Typically the caller expects that sv_any is not NULL now. */
2111 sv_upgrade(sv, SVt_IV);
2114 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
2115 PTR2UV(sv),SvIVX(sv)));
2116 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
2120 Perl_sv_2uv(pTHX_ register SV *sv)
2124 if (SvGMAGICAL(sv)) {
2129 return U_V(SvNVX(sv));
2130 if (SvPOKp(sv) && SvLEN(sv))
2133 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2134 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2140 if (SvTHINKFIRST(sv)) {
2143 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2144 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2145 return SvUV(tmpstr);
2146 return PTR2UV(SvRV(sv));
2148 if (SvREADONLY(sv) && SvFAKE(sv)) {
2149 sv_force_normal(sv);
2151 if (SvREADONLY(sv) && !SvOK(sv)) {
2152 if (ckWARN(WARN_UNINITIALIZED))
2162 return (UV)SvIVX(sv);
2166 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2167 * without also getting a cached IV/UV from it at the same time
2168 * (ie PV->NV conversion should detect loss of accuracy and cache
2169 * IV or UV at same time to avoid this. */
2170 /* IV-over-UV optimisation - choose to cache IV if possible */
2172 if (SvTYPE(sv) == SVt_NV)
2173 sv_upgrade(sv, SVt_PVNV);
2175 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2176 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2177 SvIVX(sv) = I_V(SvNVX(sv));
2178 if (SvNVX(sv) == (NV) SvIVX(sv)
2179 #ifndef NV_PRESERVES_UV
2180 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2181 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2182 /* Don't flag it as "accurately an integer" if the number
2183 came from a (by definition imprecise) NV operation, and
2184 we're outside the range of NV integer precision */
2187 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2188 DEBUG_c(PerlIO_printf(Perl_debug_log,
2189 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2195 /* IV not precise. No need to convert from PV, as NV
2196 conversion would already have cached IV if it detected
2197 that PV->IV would be better than PV->NV->IV
2198 flags already correct - don't set public IOK. */
2199 DEBUG_c(PerlIO_printf(Perl_debug_log,
2200 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2205 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2206 but the cast (NV)IV_MIN rounds to a the value less (more
2207 negative) than IV_MIN which happens to be equal to SvNVX ??
2208 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2209 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2210 (NV)UVX == NVX are both true, but the values differ. :-(
2211 Hopefully for 2s complement IV_MIN is something like
2212 0x8000000000000000 which will be exact. NWC */
2215 SvUVX(sv) = U_V(SvNVX(sv));
2217 (SvNVX(sv) == (NV) SvUVX(sv))
2218 #ifndef NV_PRESERVES_UV
2219 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2220 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2221 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2222 /* Don't flag it as "accurately an integer" if the number
2223 came from a (by definition imprecise) NV operation, and
2224 we're outside the range of NV integer precision */
2229 DEBUG_c(PerlIO_printf(Perl_debug_log,
2230 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2236 else if (SvPOKp(sv) && SvLEN(sv)) {
2238 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2240 /* We want to avoid a possible problem when we cache a UV which
2241 may be later translated to an NV, and the resulting NV is not
2242 the translation of the initial data.
2244 This means that if we cache such a UV, we need to cache the
2245 NV as well. Moreover, we trade speed for space, and do not
2246 cache the NV if not needed.
2249 /* SVt_PVNV is one higher than SVt_PVIV, hence this order */
2250 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2251 == IS_NUMBER_IN_UV) {
2252 /* It's defintately an integer, only upgrade to PVIV */
2253 if (SvTYPE(sv) < SVt_PVIV)
2254 sv_upgrade(sv, SVt_PVIV);
2256 } else if (SvTYPE(sv) < SVt_PVNV)
2257 sv_upgrade(sv, SVt_PVNV);
2259 /* If NV preserves UV then we only use the UV value if we know that
2260 we aren't going to call atof() below. If NVs don't preserve UVs
2261 then the value returned may have more precision than atof() will
2262 return, even though it isn't accurate. */
2263 if ((numtype & (IS_NUMBER_IN_UV
2264 #ifdef NV_PRESERVES_UV
2267 )) == IS_NUMBER_IN_UV) {
2268 /* This won't turn off the public IOK flag if it was set above */
2269 (void)SvIOKp_on(sv);
2271 if (!(numtype & IS_NUMBER_NEG)) {
2273 if (value <= (UV)IV_MAX) {
2274 SvIVX(sv) = (IV)value;
2276 /* it didn't overflow, and it was positive. */
2281 /* 2s complement assumption */
2282 if (value <= (UV)IV_MIN) {
2283 SvIVX(sv) = -(IV)value;
2285 /* Too negative for an IV. This is a double upgrade, but
2286 I'm assuming it will be be rare. */
2287 if (SvTYPE(sv) < SVt_PVNV)
2288 sv_upgrade(sv, SVt_PVNV);
2292 SvNVX(sv) = -(NV)value;
2298 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2299 != IS_NUMBER_IN_UV) {
2300 /* It wasn't an integer, or it overflowed the UV. */
2301 SvNVX(sv) = Atof(SvPVX(sv));
2303 if (! numtype && ckWARN(WARN_NUMERIC))
2306 #if defined(USE_LONG_DOUBLE)
2307 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2308 PTR2UV(sv), SvNVX(sv)));
2310 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2311 PTR2UV(sv), SvNVX(sv)));
2314 #ifdef NV_PRESERVES_UV
2315 (void)SvIOKp_on(sv);
2317 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2318 SvIVX(sv) = I_V(SvNVX(sv));
2319 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2322 /* Integer is imprecise. NOK, IOKp */
2324 /* UV will not work better than IV */
2326 if (SvNVX(sv) > (NV)UV_MAX) {
2328 /* Integer is inaccurate. NOK, IOKp, is UV */
2332 SvUVX(sv) = U_V(SvNVX(sv));
2333 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2334 NV preservse UV so can do correct comparison. */
2335 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2339 /* Integer is imprecise. NOK, IOKp, is UV */
2344 #else /* NV_PRESERVES_UV */
2345 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2346 == (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) {
2347 /* The UV slot will have been set from value returned by
2348 grok_number above. The NV slot has just been set using
2351 assert (SvIOKp(sv));
2353 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2354 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2355 /* Small enough to preserve all bits. */
2356 (void)SvIOKp_on(sv);
2358 SvIVX(sv) = I_V(SvNVX(sv));
2359 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2361 /* Assumption: first non-preserved integer is < IV_MAX,
2362 this NV is in the preserved range, therefore: */
2363 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2365 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);
2368 sv_2iuv_non_preserve (sv, numtype);
2370 #endif /* NV_PRESERVES_UV */
2374 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2375 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2378 if (SvTYPE(sv) < SVt_IV)
2379 /* Typically the caller expects that sv_any is not NULL now. */
2380 sv_upgrade(sv, SVt_IV);
2384 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2385 PTR2UV(sv),SvUVX(sv)));
2386 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2390 Perl_sv_2nv(pTHX_ register SV *sv)
2394 if (SvGMAGICAL(sv)) {
2398 if (SvPOKp(sv) && SvLEN(sv)) {
2399 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) &&
2400 !grok_number(SvPVX(sv), SvCUR(sv), NULL))
2402 return Atof(SvPVX(sv));
2406 return (NV)SvUVX(sv);
2408 return (NV)SvIVX(sv);
2411 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2412 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2418 if (SvTHINKFIRST(sv)) {
2421 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2422 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2423 return SvNV(tmpstr);
2424 return PTR2NV(SvRV(sv));
2426 if (SvREADONLY(sv) && SvFAKE(sv)) {
2427 sv_force_normal(sv);
2429 if (SvREADONLY(sv) && !SvOK(sv)) {
2430 if (ckWARN(WARN_UNINITIALIZED))
2435 if (SvTYPE(sv) < SVt_NV) {
2436 if (SvTYPE(sv) == SVt_IV)
2437 sv_upgrade(sv, SVt_PVNV);
2439 sv_upgrade(sv, SVt_NV);
2440 #ifdef USE_LONG_DOUBLE
2442 STORE_NUMERIC_LOCAL_SET_STANDARD();
2443 PerlIO_printf(Perl_debug_log,
2444 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2445 PTR2UV(sv), SvNVX(sv));
2446 RESTORE_NUMERIC_LOCAL();
2450 STORE_NUMERIC_LOCAL_SET_STANDARD();
2451 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2452 PTR2UV(sv), SvNVX(sv));
2453 RESTORE_NUMERIC_LOCAL();
2457 else if (SvTYPE(sv) < SVt_PVNV)
2458 sv_upgrade(sv, SVt_PVNV);
2459 if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2462 else if (SvIOKp(sv)) {
2463 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2464 #ifdef NV_PRESERVES_UV
2467 /* Only set the public NV OK flag if this NV preserves the IV */
2468 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2469 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2470 : (SvIVX(sv) == I_V(SvNVX(sv))))
2476 else if (SvPOKp(sv) && SvLEN(sv)) {
2478 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2479 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype)
2481 #ifdef NV_PRESERVES_UV
2482 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2483 == IS_NUMBER_IN_UV) {
2484 /* It's defintately an integer */
2485 SvNVX(sv) = (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value;
2487 SvNVX(sv) = Atof(SvPVX(sv));
2490 SvNVX(sv) = Atof(SvPVX(sv));
2491 /* Only set the public NV OK flag if this NV preserves the value in
2492 the PV at least as well as an IV/UV would.
2493 Not sure how to do this 100% reliably. */
2494 /* if that shift count is out of range then Configure's test is
2495 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2497 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2498 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2499 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2500 } else if (!(numtype & IS_NUMBER_IN_UV)) {
2501 /* Can't use strtol etc to convert this string, so don't try.
2502 sv_2iv and sv_2uv will use the NV to convert, not the PV. */
2505 /* value has been set. It may not be precise. */
2506 if ((numtype & IS_NUMBER_NEG) && (value > (UV)IV_MIN)) {
2507 /* 2s complement assumption for (UV)IV_MIN */
2508 SvNOK_on(sv); /* Integer is too negative. */
2513 if (numtype & IS_NUMBER_NEG) {
2514 SvIVX(sv) = -(IV)value;
2515 } else if (value <= (UV)IV_MAX) {
2516 SvIVX(sv) = (IV)value;
2522 if (numtype & IS_NUMBER_NOT_INT) {
2523 /* I believe that even if the original PV had decimals,
2524 they are lost beyond the limit of the FP precision.
2525 However, neither is canonical, so both only get p
2526 flags. NWC, 2000/11/25 */
2527 /* Both already have p flags, so do nothing */
2530 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2531 if (SvIVX(sv) == I_V(nv)) {
2536 /* It had no "." so it must be integer. */
2539 /* between IV_MAX and NV(UV_MAX).
2540 Could be slightly > UV_MAX */
2542 if (numtype & IS_NUMBER_NOT_INT) {
2543 /* UV and NV both imprecise. */
2545 UV nv_as_uv = U_V(nv);
2547 if (value == nv_as_uv && SvUVX(sv) != UV_MAX) {
2558 #endif /* NV_PRESERVES_UV */
2561 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2563 if (SvTYPE(sv) < SVt_NV)
2564 /* Typically the caller expects that sv_any is not NULL now. */
2565 /* XXX Ilya implies that this is a bug in callers that assume this
2566 and ideally should be fixed. */
2567 sv_upgrade(sv, SVt_NV);
2570 #if defined(USE_LONG_DOUBLE)
2572 STORE_NUMERIC_LOCAL_SET_STANDARD();
2573 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2574 PTR2UV(sv), SvNVX(sv));
2575 RESTORE_NUMERIC_LOCAL();
2579 STORE_NUMERIC_LOCAL_SET_STANDARD();
2580 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2581 PTR2UV(sv), SvNVX(sv));
2582 RESTORE_NUMERIC_LOCAL();
2588 /* Caller must validate PVX */
2590 S_asIV(pTHX_ SV *sv)
2593 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2595 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2596 == IS_NUMBER_IN_UV) {
2597 /* It's defintately an integer */
2598 if (numtype & IS_NUMBER_NEG) {
2599 if (value < (UV)IV_MIN)
2602 if (value < (UV)IV_MAX)
2607 if (ckWARN(WARN_NUMERIC))
2610 return I_V(Atof(SvPVX(sv)));
2614 S_asUV(pTHX_ SV *sv)
2617 int numtype = grok_number(SvPVX(sv), SvCUR(sv), &value);
2619 if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT))
2620 == IS_NUMBER_IN_UV) {
2621 /* It's defintately an integer */
2622 if (!(numtype & IS_NUMBER_NEG))
2626 if (ckWARN(WARN_NUMERIC))
2629 return U_V(Atof(SvPVX(sv)));
2633 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2636 return sv_2pv(sv, &n_a);
2639 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2641 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2643 char *ptr = buf + TYPE_CHARS(UV);
2657 *--ptr = '0' + (uv % 10);
2666 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2668 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2672 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2677 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2678 char *tmpbuf = tbuf;
2684 if (SvGMAGICAL(sv)) {
2685 if (flags & SV_GMAGIC)
2693 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2695 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2700 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2705 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2706 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2713 if (SvTHINKFIRST(sv)) {
2716 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2717 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2718 return SvPV(tmpstr,*lp);
2725 switch (SvTYPE(sv)) {
2727 if ( ((SvFLAGS(sv) &
2728 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2729 == (SVs_OBJECT|SVs_RMG))
2730 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2731 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2732 regexp *re = (regexp *)mg->mg_obj;
2735 char *fptr = "msix";
2740 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2742 while((ch = *fptr++)) {
2744 reflags[left++] = ch;
2747 reflags[right--] = ch;
2752 reflags[left] = '-';
2756 mg->mg_len = re->prelen + 4 + left;
2757 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2758 Copy("(?", mg->mg_ptr, 2, char);
2759 Copy(reflags, mg->mg_ptr+2, left, char);
2760 Copy(":", mg->mg_ptr+left+2, 1, char);
2761 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2762 mg->mg_ptr[mg->mg_len - 1] = ')';
2763 mg->mg_ptr[mg->mg_len] = 0;
2765 PL_reginterp_cnt += re->program[0].next_off;
2777 case SVt_PVBM: if (SvROK(sv))
2780 s = "SCALAR"; break;
2781 case SVt_PVLV: s = "LVALUE"; break;
2782 case SVt_PVAV: s = "ARRAY"; break;
2783 case SVt_PVHV: s = "HASH"; break;
2784 case SVt_PVCV: s = "CODE"; break;
2785 case SVt_PVGV: s = "GLOB"; break;
2786 case SVt_PVFM: s = "FORMAT"; break;
2787 case SVt_PVIO: s = "IO"; break;
2788 default: s = "UNKNOWN"; break;
2792 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2795 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2801 if (SvREADONLY(sv) && !SvOK(sv)) {
2802 if (ckWARN(WARN_UNINITIALIZED))
2808 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2809 /* I'm assuming that if both IV and NV are equally valid then
2810 converting the IV is going to be more efficient */
2811 U32 isIOK = SvIOK(sv);
2812 U32 isUIOK = SvIsUV(sv);
2813 char buf[TYPE_CHARS(UV)];
2816 if (SvTYPE(sv) < SVt_PVIV)
2817 sv_upgrade(sv, SVt_PVIV);
2819 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2821 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2822 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2823 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2824 SvCUR_set(sv, ebuf - ptr);
2834 else if (SvNOKp(sv)) {
2835 if (SvTYPE(sv) < SVt_PVNV)
2836 sv_upgrade(sv, SVt_PVNV);
2837 /* The +20 is pure guesswork. Configure test needed. --jhi */
2838 SvGROW(sv, NV_DIG + 20);
2840 olderrno = errno; /* some Xenix systems wipe out errno here */
2842 if (SvNVX(sv) == 0.0)
2843 (void)strcpy(s,"0");
2847 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2850 #ifdef FIXNEGATIVEZERO
2851 if (*s == '-' && s[1] == '0' && !s[2])
2861 if (ckWARN(WARN_UNINITIALIZED)
2862 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2865 if (SvTYPE(sv) < SVt_PV)
2866 /* Typically the caller expects that sv_any is not NULL now. */
2867 sv_upgrade(sv, SVt_PV);
2870 *lp = s - SvPVX(sv);
2873 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2874 PTR2UV(sv),SvPVX(sv)));
2878 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2879 /* Sneaky stuff here */
2883 tsv = newSVpv(tmpbuf, 0);
2899 len = strlen(tmpbuf);
2901 #ifdef FIXNEGATIVEZERO
2902 if (len == 2 && t[0] == '-' && t[1] == '0') {
2907 (void)SvUPGRADE(sv, SVt_PV);
2909 s = SvGROW(sv, len + 1);
2918 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2921 return sv_2pvbyte(sv, &n_a);
2925 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2927 sv_utf8_downgrade(sv,0);
2928 return SvPV(sv,*lp);
2932 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2935 return sv_2pvutf8(sv, &n_a);
2939 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2941 sv_utf8_upgrade(sv);
2942 return SvPV(sv,*lp);
2945 /* This function is only called on magical items */
2947 Perl_sv_2bool(pTHX_ register SV *sv)
2956 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2957 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
2958 return SvTRUE(tmpsv);
2959 return SvRV(sv) != 0;
2962 register XPV* Xpvtmp;
2963 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2964 (*Xpvtmp->xpv_pv > '0' ||
2965 Xpvtmp->xpv_cur > 1 ||
2966 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2973 return SvIVX(sv) != 0;
2976 return SvNVX(sv) != 0.0;
2984 =for apidoc sv_utf8_upgrade
2986 Convert the PV of an SV to its UTF8-encoded form.
2987 Forces the SV to string form it it is not already.
2988 Always sets the SvUTF8 flag to avoid future validity checks even
2989 if all the bytes have hibit clear.
2995 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2997 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
3001 =for apidoc sv_utf8_upgrade_flags
3003 Convert the PV of an SV to its UTF8-encoded form.
3004 Forces the SV to string form it it is not already.
3005 Always sets the SvUTF8 flag to avoid future validity checks even
3006 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
3007 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
3008 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
3014 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3024 (void) sv_2pv_flags(sv,&len, flags);
3032 if (SvREADONLY(sv) && SvFAKE(sv)) {
3033 sv_force_normal(sv);
3036 /* This function could be much more efficient if we had a FLAG in SVs
3037 * to signal if there are any hibit chars in the PV.
3038 * Given that there isn't make loop fast as possible
3040 s = (U8 *) SvPVX(sv);
3041 e = (U8 *) SvEND(sv);
3045 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3051 len = SvCUR(sv) + 1; /* Plus the \0 */
3052 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3053 SvCUR(sv) = len - 1;
3055 Safefree(s); /* No longer using what was there before. */
3056 SvLEN(sv) = len; /* No longer know the real size. */
3058 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3064 =for apidoc sv_utf8_downgrade
3066 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3067 This may not be possible if the PV contains non-byte encoding characters;
3068 if this is the case, either returns false or, if C<fail_ok> is not
3075 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3077 if (SvPOK(sv) && SvUTF8(sv)) {
3082 if (SvREADONLY(sv) && SvFAKE(sv))
3083 sv_force_normal(sv);
3084 s = (U8 *) SvPV(sv, len);
3085 if (!utf8_to_bytes(s, &len)) {
3088 #ifdef USE_BYTES_DOWNGRADES
3089 else if (IN_BYTES) {
3091 U8 *e = (U8 *) SvEND(sv);
3094 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3095 if (first && ch > 255) {
3097 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3098 PL_op_desc[PL_op->op_type]);
3100 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3107 len = (d - (U8 *) SvPVX(sv));
3112 Perl_croak(aTHX_ "Wide character in %s",
3113 PL_op_desc[PL_op->op_type]);
3115 Perl_croak(aTHX_ "Wide character");
3126 =for apidoc sv_utf8_encode
3128 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3129 flag so that it looks like octets again. Used as a building block
3130 for encode_utf8 in Encode.xs
3136 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3138 (void) sv_utf8_upgrade(sv);
3143 =for apidoc sv_utf8_decode
3145 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3146 turn of SvUTF8 if needed so that we see characters. Used as a building block
3147 for decode_utf8 in Encode.xs
3155 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3161 /* The octets may have got themselves encoded - get them back as bytes */
3162 if (!sv_utf8_downgrade(sv, TRUE))
3165 /* it is actually just a matter of turning the utf8 flag on, but
3166 * we want to make sure everything inside is valid utf8 first.
3168 c = (U8 *) SvPVX(sv);
3169 if (!is_utf8_string(c, SvCUR(sv)+1))
3171 e = (U8 *) SvEND(sv);
3174 if (!UTF8_IS_INVARIANT(ch)) {
3184 /* Note: sv_setsv() should not be called with a source string that needs
3185 * to be reused, since it may destroy the source string if it is marked
3190 =for apidoc sv_setsv
3192 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3193 The source SV may be destroyed if it is mortal. Does not handle 'set'
3194 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3200 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3201 for binary compatibility only
3204 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3206 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3210 =for apidoc sv_setsv_flags
3212 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3213 The source SV may be destroyed if it is mortal. Does not handle 'set'
3214 magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
3215 appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
3216 in terms of this function.
3222 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3224 register U32 sflags;
3230 SV_CHECK_THINKFIRST(dstr);
3232 sstr = &PL_sv_undef;
3233 stype = SvTYPE(sstr);
3234 dtype = SvTYPE(dstr);
3238 /* There's a lot of redundancy below but we're going for speed here */
3243 if (dtype != SVt_PVGV) {
3244 (void)SvOK_off(dstr);
3252 sv_upgrade(dstr, SVt_IV);
3255 sv_upgrade(dstr, SVt_PVNV);
3259 sv_upgrade(dstr, SVt_PVIV);
3262 (void)SvIOK_only(dstr);
3263 SvIVX(dstr) = SvIVX(sstr);
3266 if (SvTAINTED(sstr))
3277 sv_upgrade(dstr, SVt_NV);
3282 sv_upgrade(dstr, SVt_PVNV);
3285 SvNVX(dstr) = SvNVX(sstr);
3286 (void)SvNOK_only(dstr);
3287 if (SvTAINTED(sstr))
3295 sv_upgrade(dstr, SVt_RV);
3296 else if (dtype == SVt_PVGV &&
3297 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3300 if (GvIMPORTED(dstr) != GVf_IMPORTED
3301 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3303 GvIMPORTED_on(dstr);
3314 sv_upgrade(dstr, SVt_PV);
3317 if (dtype < SVt_PVIV)
3318 sv_upgrade(dstr, SVt_PVIV);
3321 if (dtype < SVt_PVNV)
3322 sv_upgrade(dstr, SVt_PVNV);
3329 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3330 PL_op_name[PL_op->op_type]);
3332 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3336 if (dtype <= SVt_PVGV) {
3338 if (dtype != SVt_PVGV) {
3339 char *name = GvNAME(sstr);
3340 STRLEN len = GvNAMELEN(sstr);
3341 sv_upgrade(dstr, SVt_PVGV);
3342 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3343 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3344 GvNAME(dstr) = savepvn(name, len);
3345 GvNAMELEN(dstr) = len;
3346 SvFAKE_on(dstr); /* can coerce to non-glob */
3348 /* ahem, death to those who redefine active sort subs */
3349 else if (PL_curstackinfo->si_type == PERLSI_SORT
3350 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3351 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3354 #ifdef GV_SHARED_CHECK
3355 if (GvSHARED((GV*)dstr)) {
3356 Perl_croak(aTHX_ PL_no_modify);
3360 (void)SvOK_off(dstr);
3361 GvINTRO_off(dstr); /* one-shot flag */
3363 GvGP(dstr) = gp_ref(GvGP(sstr));
3364 if (SvTAINTED(sstr))
3366 if (GvIMPORTED(dstr) != GVf_IMPORTED
3367 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3369 GvIMPORTED_on(dstr);
3377 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3379 if (SvTYPE(sstr) != stype) {
3380 stype = SvTYPE(sstr);
3381 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3385 if (stype == SVt_PVLV)
3386 (void)SvUPGRADE(dstr, SVt_PVNV);
3388 (void)SvUPGRADE(dstr, stype);
3391 sflags = SvFLAGS(sstr);
3393 if (sflags & SVf_ROK) {
3394 if (dtype >= SVt_PV) {
3395 if (dtype == SVt_PVGV) {
3396 SV *sref = SvREFCNT_inc(SvRV(sstr));
3398 int intro = GvINTRO(dstr);
3400 #ifdef GV_SHARED_CHECK
3401 if (GvSHARED((GV*)dstr)) {
3402 Perl_croak(aTHX_ PL_no_modify);
3409 GvINTRO_off(dstr); /* one-shot flag */
3410 Newz(602,gp, 1, GP);
3411 GvGP(dstr) = gp_ref(gp);
3412 GvSV(dstr) = NEWSV(72,0);
3413 GvLINE(dstr) = CopLINE(PL_curcop);
3414 GvEGV(dstr) = (GV*)dstr;
3417 switch (SvTYPE(sref)) {
3420 SAVESPTR(GvAV(dstr));
3422 dref = (SV*)GvAV(dstr);
3423 GvAV(dstr) = (AV*)sref;
3424 if (!GvIMPORTED_AV(dstr)
3425 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3427 GvIMPORTED_AV_on(dstr);
3432 SAVESPTR(GvHV(dstr));
3434 dref = (SV*)GvHV(dstr);
3435 GvHV(dstr) = (HV*)sref;
3436 if (!GvIMPORTED_HV(dstr)
3437 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3439 GvIMPORTED_HV_on(dstr);
3444 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3445 SvREFCNT_dec(GvCV(dstr));
3446 GvCV(dstr) = Nullcv;
3447 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3448 PL_sub_generation++;
3450 SAVESPTR(GvCV(dstr));
3453 dref = (SV*)GvCV(dstr);
3454 if (GvCV(dstr) != (CV*)sref) {
3455 CV* cv = GvCV(dstr);
3457 if (!GvCVGEN((GV*)dstr) &&
3458 (CvROOT(cv) || CvXSUB(cv)))
3460 /* ahem, death to those who redefine
3461 * active sort subs */
3462 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3463 PL_sortcop == CvSTART(cv))
3465 "Can't redefine active sort subroutine %s",
3466 GvENAME((GV*)dstr));
3467 /* Redefining a sub - warning is mandatory if
3468 it was a const and its value changed. */
3469 if (ckWARN(WARN_REDEFINE)
3471 && (!CvCONST((CV*)sref)
3472 || sv_cmp(cv_const_sv(cv),
3473 cv_const_sv((CV*)sref)))))
3475 Perl_warner(aTHX_ WARN_REDEFINE,
3477 ? "Constant subroutine %s redefined"
3478 : "Subroutine %s redefined",
3479 GvENAME((GV*)dstr));
3482 cv_ckproto(cv, (GV*)dstr,
3483 SvPOK(sref) ? SvPVX(sref) : Nullch);
3485 GvCV(dstr) = (CV*)sref;
3486 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3487 GvASSUMECV_on(dstr);
3488 PL_sub_generation++;
3490 if (!GvIMPORTED_CV(dstr)
3491 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3493 GvIMPORTED_CV_on(dstr);
3498 SAVESPTR(GvIOp(dstr));
3500 dref = (SV*)GvIOp(dstr);
3501 GvIOp(dstr) = (IO*)sref;
3505 SAVESPTR(GvFORM(dstr));
3507 dref = (SV*)GvFORM(dstr);
3508 GvFORM(dstr) = (CV*)sref;
3512 SAVESPTR(GvSV(dstr));
3514 dref = (SV*)GvSV(dstr);
3516 if (!GvIMPORTED_SV(dstr)
3517 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3519 GvIMPORTED_SV_on(dstr);
3527 if (SvTAINTED(sstr))
3532 (void)SvOOK_off(dstr); /* backoff */
3534 Safefree(SvPVX(dstr));
3535 SvLEN(dstr)=SvCUR(dstr)=0;
3538 (void)SvOK_off(dstr);
3539 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3541 if (sflags & SVp_NOK) {
3543 /* Only set the public OK flag if the source has public OK. */
3544 if (sflags & SVf_NOK)
3545 SvFLAGS(dstr) |= SVf_NOK;
3546 SvNVX(dstr) = SvNVX(sstr);
3548 if (sflags & SVp_IOK) {
3549 (void)SvIOKp_on(dstr);
3550 if (sflags & SVf_IOK)
3551 SvFLAGS(dstr) |= SVf_IOK;
3552 if (sflags & SVf_IVisUV)
3554 SvIVX(dstr) = SvIVX(sstr);
3556 if (SvAMAGIC(sstr)) {
3560 else if (sflags & SVp_POK) {
3563 * Check to see if we can just swipe the string. If so, it's a
3564 * possible small lose on short strings, but a big win on long ones.
3565 * It might even be a win on short strings if SvPVX(dstr)
3566 * has to be allocated and SvPVX(sstr) has to be freed.
3569 if (SvTEMP(sstr) && /* slated for free anyway? */
3570 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3571 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3572 SvLEN(sstr) && /* and really is a string */
3573 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3575 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3577 SvFLAGS(dstr) &= ~SVf_OOK;
3578 Safefree(SvPVX(dstr) - SvIVX(dstr));
3580 else if (SvLEN(dstr))
3581 Safefree(SvPVX(dstr));
3583 (void)SvPOK_only(dstr);
3584 SvPV_set(dstr, SvPVX(sstr));
3585 SvLEN_set(dstr, SvLEN(sstr));
3586 SvCUR_set(dstr, SvCUR(sstr));
3589 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3590 SvPV_set(sstr, Nullch);
3595 else { /* have to copy actual string */
3596 STRLEN len = SvCUR(sstr);
3598 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3599 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3600 SvCUR_set(dstr, len);
3601 *SvEND(dstr) = '\0';
3602 (void)SvPOK_only(dstr);
3604 if (sflags & SVf_UTF8)
3607 if (sflags & SVp_NOK) {
3609 if (sflags & SVf_NOK)
3610 SvFLAGS(dstr) |= SVf_NOK;
3611 SvNVX(dstr) = SvNVX(sstr);
3613 if (sflags & SVp_IOK) {
3614 (void)SvIOKp_on(dstr);
3615 if (sflags & SVf_IOK)
3616 SvFLAGS(dstr) |= SVf_IOK;
3617 if (sflags & SVf_IVisUV)
3619 SvIVX(dstr) = SvIVX(sstr);
3622 else if (sflags & SVp_IOK) {
3623 if (sflags & SVf_IOK)
3624 (void)SvIOK_only(dstr);
3626 (void)SvOK_off(dstr);
3627 (void)SvIOKp_on(dstr);
3629 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3630 if (sflags & SVf_IVisUV)
3632 SvIVX(dstr) = SvIVX(sstr);
3633 if (sflags & SVp_NOK) {
3634 if (sflags & SVf_NOK)
3635 (void)SvNOK_on(dstr);
3637 (void)SvNOKp_on(dstr);
3638 SvNVX(dstr) = SvNVX(sstr);
3641 else if (sflags & SVp_NOK) {
3642 if (sflags & SVf_NOK)
3643 (void)SvNOK_only(dstr);
3645 (void)SvOK_off(dstr);
3648 SvNVX(dstr) = SvNVX(sstr);
3651 if (dtype == SVt_PVGV) {
3652 if (ckWARN(WARN_MISC))
3653 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3656 (void)SvOK_off(dstr);
3658 if (SvTAINTED(sstr))
3663 =for apidoc sv_setsv_mg
3665 Like C<sv_setsv>, but also handles 'set' magic.
3671 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3673 sv_setsv(dstr,sstr);
3678 =for apidoc sv_setpvn
3680 Copies a string into an SV. The C<len> parameter indicates the number of
3681 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3687 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3689 register char *dptr;
3691 SV_CHECK_THINKFIRST(sv);
3697 /* len is STRLEN which is unsigned, need to copy to signed */
3700 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3702 (void)SvUPGRADE(sv, SVt_PV);
3704 SvGROW(sv, len + 1);
3706 Move(ptr,dptr,len,char);
3709 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3714 =for apidoc sv_setpvn_mg
3716 Like C<sv_setpvn>, but also handles 'set' magic.
3722 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3724 sv_setpvn(sv,ptr,len);
3729 =for apidoc sv_setpv
3731 Copies a string into an SV. The string must be null-terminated. Does not
3732 handle 'set' magic. See C<sv_setpv_mg>.
3738 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3740 register STRLEN len;
3742 SV_CHECK_THINKFIRST(sv);
3748 (void)SvUPGRADE(sv, SVt_PV);
3750 SvGROW(sv, len + 1);
3751 Move(ptr,SvPVX(sv),len+1,char);
3753 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3758 =for apidoc sv_setpv_mg
3760 Like C<sv_setpv>, but also handles 'set' magic.
3766 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3773 =for apidoc sv_usepvn
3775 Tells an SV to use C<ptr> to find its string value. Normally the string is
3776 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3777 The C<ptr> should point to memory that was allocated by C<malloc>. The
3778 string length, C<len>, must be supplied. This function will realloc the
3779 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3780 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3781 See C<sv_usepvn_mg>.
3787 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3789 SV_CHECK_THINKFIRST(sv);
3790 (void)SvUPGRADE(sv, SVt_PV);
3795 (void)SvOOK_off(sv);
3796 if (SvPVX(sv) && SvLEN(sv))
3797 Safefree(SvPVX(sv));
3798 Renew(ptr, len+1, char);
3801 SvLEN_set(sv, len+1);
3803 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3808 =for apidoc sv_usepvn_mg
3810 Like C<sv_usepvn>, but also handles 'set' magic.
3816 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3818 sv_usepvn(sv,ptr,len);
3823 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3825 if (SvREADONLY(sv)) {
3827 char *pvx = SvPVX(sv);
3828 STRLEN len = SvCUR(sv);
3829 U32 hash = SvUVX(sv);
3830 SvGROW(sv, len + 1);
3831 Move(pvx,SvPVX(sv),len,char);
3835 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3837 else if (PL_curcop != &PL_compiling)
3838 Perl_croak(aTHX_ PL_no_modify);
3841 sv_unref_flags(sv, flags);
3842 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3847 Perl_sv_force_normal(pTHX_ register SV *sv)
3849 sv_force_normal_flags(sv, 0);
3855 Efficient removal of characters from the beginning of the string buffer.
3856 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3857 the string buffer. The C<ptr> becomes the first character of the adjusted
3864 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3868 register STRLEN delta;
3870 if (!ptr || !SvPOKp(sv))
3872 SV_CHECK_THINKFIRST(sv);
3873 if (SvTYPE(sv) < SVt_PVIV)
3874 sv_upgrade(sv,SVt_PVIV);
3877 if (!SvLEN(sv)) { /* make copy of shared string */
3878 char *pvx = SvPVX(sv);
3879 STRLEN len = SvCUR(sv);
3880 SvGROW(sv, len + 1);
3881 Move(pvx,SvPVX(sv),len,char);
3885 SvFLAGS(sv) |= SVf_OOK;
3887 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3888 delta = ptr - SvPVX(sv);
3896 =for apidoc sv_catpvn
3898 Concatenates the string onto the end of the string which is in the SV. The
3899 C<len> indicates number of bytes to copy. If the SV has the UTF8
3900 status set, then the bytes appended should be valid UTF8.
3901 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3906 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
3907 for binary compatibility only
3910 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
3912 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
3916 =for apidoc sv_catpvn_flags
3918 Concatenates the string onto the end of the string which is in the SV. The
3919 C<len> indicates number of bytes to copy. If the SV has the UTF8
3920 status set, then the bytes appended should be valid UTF8.
3921 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3922 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3923 in terms of this function.
3929 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3934 dstr = SvPV_force_flags(dsv, dlen, flags);
3935 SvGROW(dsv, dlen + slen + 1);
3938 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3941 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3946 =for apidoc sv_catpvn_mg
3948 Like C<sv_catpvn>, but also handles 'set' magic.
3954 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3956 sv_catpvn(sv,ptr,len);
3961 =for apidoc sv_catsv
3963 Concatenates the string from SV C<ssv> onto the end of the string in
3964 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3965 not 'set' magic. See C<sv_catsv_mg>.
3969 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
3970 for binary compatibility only
3973 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3975 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
3979 =for apidoc sv_catsv_flags
3981 Concatenates the string from SV C<ssv> onto the end of the string in
3982 SV C<dsv>. Modifies C<dsv> but not C<ssv>. If C<flags> has C<SV_GMAGIC>
3983 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3984 and C<sv_catsv_nomg> are implemented in terms of this function.
3989 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3995 if ((spv = SvPV(ssv, slen))) {
3996 bool sutf8 = DO_UTF8(ssv);
3999 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
4001 dutf8 = DO_UTF8(dsv);
4003 if (dutf8 != sutf8) {
4005 /* Not modifying source SV, so taking a temporary copy. */
4006 SV* csv = sv_2mortal(newSVpvn(spv, slen));
4008 sv_utf8_upgrade(csv);
4009 spv = SvPV(csv, slen);
4012 sv_utf8_upgrade_nomg(dsv);
4014 sv_catpvn_nomg(dsv, spv, slen);
4019 =for apidoc sv_catsv_mg
4021 Like C<sv_catsv>, but also handles 'set' magic.
4027 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4034 =for apidoc sv_catpv
4036 Concatenates the string onto the end of the string which is in the SV.
4037 If the SV has the UTF8 status set, then the bytes appended should be
4038 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4043 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4045 register STRLEN len;
4051 junk = SvPV_force(sv, tlen);
4053 SvGROW(sv, tlen + len + 1);
4056 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4058 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4063 =for apidoc sv_catpv_mg
4065 Like C<sv_catpv>, but also handles 'set' magic.
4071 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4078 Perl_newSV(pTHX_ STRLEN len)
4084 sv_upgrade(sv, SVt_PV);
4085 SvGROW(sv, len + 1);
4090 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
4093 =for apidoc sv_magic
4095 Adds magic to an SV.
4101 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4105 if (SvREADONLY(sv)) {
4106 if (PL_curcop != &PL_compiling
4107 /* XXX this used to be !strchr("gBf", how), which seems to
4108 * implicity be equal to !strchr("gBf\0", how), ie \0 matches
4109 * too. I find this suprising, but have hadded PERL_MAGIC_sv
4110 * to the list of things to check - DAPM 19-May-01 */
4111 && how != PERL_MAGIC_regex_global
4112 && how != PERL_MAGIC_bm
4113 && how != PERL_MAGIC_fm
4114 && how != PERL_MAGIC_sv
4117 Perl_croak(aTHX_ PL_no_modify);
4120 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4121 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4122 if (how == PERL_MAGIC_taint)
4128 (void)SvUPGRADE(sv, SVt_PVMG);
4130 Newz(702,mg, 1, MAGIC);
4131 mg->mg_moremagic = SvMAGIC(sv);
4134 /* Some magic sontains a reference loop, where the sv and object refer to
4135 each other. To prevent a avoid a reference loop that would prevent such
4136 objects being freed, we look for such loops and if we find one we avoid
4137 incrementing the object refcount. */
4138 if (!obj || obj == sv ||
4139 how == PERL_MAGIC_arylen ||
4140 how == PERL_MAGIC_qr ||
4141 (SvTYPE(obj) == SVt_PVGV &&
4142 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4143 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4144 GvFORM(obj) == (CV*)sv)))
4149 mg->mg_obj = SvREFCNT_inc(obj);
4150 mg->mg_flags |= MGf_REFCOUNTED;
4153 mg->mg_len = namlen;
4156 mg->mg_ptr = savepvn(name, namlen);
4157 else if (namlen == HEf_SVKEY)
4158 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4163 mg->mg_virtual = &PL_vtbl_sv;
4165 case PERL_MAGIC_overload:
4166 mg->mg_virtual = &PL_vtbl_amagic;
4168 case PERL_MAGIC_overload_elem:
4169 mg->mg_virtual = &PL_vtbl_amagicelem;
4171 case PERL_MAGIC_overload_table:
4172 mg->mg_virtual = &PL_vtbl_ovrld;
4175 mg->mg_virtual = &PL_vtbl_bm;
4177 case PERL_MAGIC_regdata:
4178 mg->mg_virtual = &PL_vtbl_regdata;
4180 case PERL_MAGIC_regdatum:
4181 mg->mg_virtual = &PL_vtbl_regdatum;
4183 case PERL_MAGIC_env:
4184 mg->mg_virtual = &PL_vtbl_env;
4187 mg->mg_virtual = &PL_vtbl_fm;
4189 case PERL_MAGIC_envelem:
4190 mg->mg_virtual = &PL_vtbl_envelem;
4192 case PERL_MAGIC_regex_global:
4193 mg->mg_virtual = &PL_vtbl_mglob;
4195 case PERL_MAGIC_isa:
4196 mg->mg_virtual = &PL_vtbl_isa;
4198 case PERL_MAGIC_isaelem:
4199 mg->mg_virtual = &PL_vtbl_isaelem;
4201 case PERL_MAGIC_nkeys:
4202 mg->mg_virtual = &PL_vtbl_nkeys;
4204 case PERL_MAGIC_dbfile:
4208 case PERL_MAGIC_dbline:
4209 mg->mg_virtual = &PL_vtbl_dbline;
4212 case PERL_MAGIC_mutex:
4213 mg->mg_virtual = &PL_vtbl_mutex;
4215 #endif /* USE_THREADS */
4216 #ifdef USE_LOCALE_COLLATE
4217 case PERL_MAGIC_collxfrm:
4218 mg->mg_virtual = &PL_vtbl_collxfrm;
4220 #endif /* USE_LOCALE_COLLATE */
4221 case PERL_MAGIC_tied:
4222 mg->mg_virtual = &PL_vtbl_pack;
4224 case PERL_MAGIC_tiedelem:
4225 case PERL_MAGIC_tiedscalar:
4226 mg->mg_virtual = &PL_vtbl_packelem;
4229 mg->mg_virtual = &PL_vtbl_regexp;
4231 case PERL_MAGIC_sig:
4232 mg->mg_virtual = &PL_vtbl_sig;
4234 case PERL_MAGIC_sigelem:
4235 mg->mg_virtual = &PL_vtbl_sigelem;
4237 case PERL_MAGIC_taint:
4238 mg->mg_virtual = &PL_vtbl_taint;
4241 case PERL_MAGIC_uvar:
4242 mg->mg_virtual = &PL_vtbl_uvar;
4244 case PERL_MAGIC_vec:
4245 mg->mg_virtual = &PL_vtbl_vec;
4247 case PERL_MAGIC_substr:
4248 mg->mg_virtual = &PL_vtbl_substr;
4250 case PERL_MAGIC_defelem:
4251 mg->mg_virtual = &PL_vtbl_defelem;
4253 case PERL_MAGIC_glob:
4254 mg->mg_virtual = &PL_vtbl_glob;
4256 case PERL_MAGIC_arylen:
4257 mg->mg_virtual = &PL_vtbl_arylen;
4259 case PERL_MAGIC_pos:
4260 mg->mg_virtual = &PL_vtbl_pos;
4262 case PERL_MAGIC_backref:
4263 mg->mg_virtual = &PL_vtbl_backref;
4265 case PERL_MAGIC_ext:
4266 /* Reserved for use by extensions not perl internals. */
4267 /* Useful for attaching extension internal data to perl vars. */
4268 /* Note that multiple extensions may clash if magical scalars */
4269 /* etc holding private data from one are passed to another. */
4273 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4277 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4281 =for apidoc sv_unmagic
4283 Removes magic from an SV.
4289 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4293 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4296 for (mg = *mgp; mg; mg = *mgp) {
4297 if (mg->mg_type == type) {
4298 MGVTBL* vtbl = mg->mg_virtual;
4299 *mgp = mg->mg_moremagic;
4300 if (vtbl && vtbl->svt_free)
4301 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4302 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4303 if (mg->mg_len >= 0)
4304 Safefree(mg->mg_ptr);
4305 else if (mg->mg_len == HEf_SVKEY)
4306 SvREFCNT_dec((SV*)mg->mg_ptr);
4308 if (mg->mg_flags & MGf_REFCOUNTED)
4309 SvREFCNT_dec(mg->mg_obj);
4313 mgp = &mg->mg_moremagic;
4317 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4324 =for apidoc sv_rvweaken
4332 Perl_sv_rvweaken(pTHX_ SV *sv)
4335 if (!SvOK(sv)) /* let undefs pass */
4338 Perl_croak(aTHX_ "Can't weaken a nonreference");
4339 else if (SvWEAKREF(sv)) {
4340 if (ckWARN(WARN_MISC))
4341 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4345 sv_add_backref(tsv, sv);
4352 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4356 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4357 av = (AV*)mg->mg_obj;
4360 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4361 SvREFCNT_dec(av); /* for sv_magic */
4367 S_sv_del_backref(pTHX_ SV *sv)
4374 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4375 Perl_croak(aTHX_ "panic: del_backref");
4376 av = (AV *)mg->mg_obj;
4381 svp[i] = &PL_sv_undef; /* XXX */
4388 =for apidoc sv_insert
4390 Inserts a string at the specified offset/length within the SV. Similar to
4391 the Perl substr() function.
4397 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4401 register char *midend;
4402 register char *bigend;
4408 Perl_croak(aTHX_ "Can't modify non-existent substring");
4409 SvPV_force(bigstr, curlen);
4410 (void)SvPOK_only_UTF8(bigstr);
4411 if (offset + len > curlen) {
4412 SvGROW(bigstr, offset+len+1);
4413 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4414 SvCUR_set(bigstr, offset+len);
4418 i = littlelen - len;
4419 if (i > 0) { /* string might grow */
4420 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4421 mid = big + offset + len;
4422 midend = bigend = big + SvCUR(bigstr);
4425 while (midend > mid) /* shove everything down */
4426 *--bigend = *--midend;
4427 Move(little,big+offset,littlelen,char);
4433 Move(little,SvPVX(bigstr)+offset,len,char);
4438 big = SvPVX(bigstr);
4441 bigend = big + SvCUR(bigstr);
4443 if (midend > bigend)
4444 Perl_croak(aTHX_ "panic: sv_insert");
4446 if (mid - big > bigend - midend) { /* faster to shorten from end */
4448 Move(little, mid, littlelen,char);
4451 i = bigend - midend;
4453 Move(midend, mid, i,char);
4457 SvCUR_set(bigstr, mid - big);
4460 else if ((i = mid - big)) { /* faster from front */
4461 midend -= littlelen;
4463 sv_chop(bigstr,midend-i);
4468 Move(little, mid, littlelen,char);
4470 else if (littlelen) {
4471 midend -= littlelen;
4472 sv_chop(bigstr,midend);
4473 Move(little,midend,littlelen,char);
4476 sv_chop(bigstr,midend);
4482 =for apidoc sv_replace
4484 Make the first argument a copy of the second, then delete the original.
4490 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4492 U32 refcnt = SvREFCNT(sv);
4493 SV_CHECK_THINKFIRST(sv);
4494 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4495 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4496 if (SvMAGICAL(sv)) {
4500 sv_upgrade(nsv, SVt_PVMG);
4501 SvMAGIC(nsv) = SvMAGIC(sv);
4502 SvFLAGS(nsv) |= SvMAGICAL(sv);
4508 assert(!SvREFCNT(sv));
4509 StructCopy(nsv,sv,SV);
4510 SvREFCNT(sv) = refcnt;
4511 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4516 =for apidoc sv_clear
4518 Clear an SV, making it empty. Does not free the memory used by the SV
4525 Perl_sv_clear(pTHX_ register SV *sv)
4529 assert(SvREFCNT(sv) == 0);
4532 if (PL_defstash) { /* Still have a symbol table? */
4537 Zero(&tmpref, 1, SV);
4538 sv_upgrade(&tmpref, SVt_RV);
4540 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4541 SvREFCNT(&tmpref) = 1;
4544 stash = SvSTASH(sv);
4545 destructor = StashHANDLER(stash,DESTROY);
4548 PUSHSTACKi(PERLSI_DESTROY);
4549 SvRV(&tmpref) = SvREFCNT_inc(sv);
4554 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4560 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4562 del_XRV(SvANY(&tmpref));
4565 if (PL_in_clean_objs)
4566 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4568 /* DESTROY gave object new lease on life */
4574 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4575 SvOBJECT_off(sv); /* Curse the object. */
4576 if (SvTYPE(sv) != SVt_PVIO)
4577 --PL_sv_objcount; /* XXX Might want something more general */
4580 if (SvTYPE(sv) >= SVt_PVMG) {
4583 if (SvFLAGS(sv) & SVpad_TYPED)
4584 SvREFCNT_dec(SvSTASH(sv));
4587 switch (SvTYPE(sv)) {
4590 IoIFP(sv) != PerlIO_stdin() &&
4591 IoIFP(sv) != PerlIO_stdout() &&
4592 IoIFP(sv) != PerlIO_stderr())
4594 io_close((IO*)sv, FALSE);
4596 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4597 PerlDir_close(IoDIRP(sv));
4598 IoDIRP(sv) = (DIR*)NULL;
4599 Safefree(IoTOP_NAME(sv));
4600 Safefree(IoFMT_NAME(sv));
4601 Safefree(IoBOTTOM_NAME(sv));
4616 SvREFCNT_dec(LvTARG(sv));
4620 Safefree(GvNAME(sv));
4621 /* cannot decrease stash refcount yet, as we might recursively delete
4622 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4623 of stash until current sv is completely gone.
4624 -- JohnPC, 27 Mar 1998 */
4625 stash = GvSTASH(sv);
4631 (void)SvOOK_off(sv);
4639 SvREFCNT_dec(SvRV(sv));
4641 else if (SvPVX(sv) && SvLEN(sv))
4642 Safefree(SvPVX(sv));
4643 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4644 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4656 switch (SvTYPE(sv)) {
4672 del_XPVIV(SvANY(sv));
4675 del_XPVNV(SvANY(sv));
4678 del_XPVMG(SvANY(sv));
4681 del_XPVLV(SvANY(sv));
4684 del_XPVAV(SvANY(sv));
4687 del_XPVHV(SvANY(sv));
4690 del_XPVCV(SvANY(sv));
4693 del_XPVGV(SvANY(sv));
4694 /* code duplication for increased performance. */
4695 SvFLAGS(sv) &= SVf_BREAK;
4696 SvFLAGS(sv) |= SVTYPEMASK;
4697 /* decrease refcount of the stash that owns this GV, if any */
4699 SvREFCNT_dec(stash);
4700 return; /* not break, SvFLAGS reset already happened */
4702 del_XPVBM(SvANY(sv));
4705 del_XPVFM(SvANY(sv));
4708 del_XPVIO(SvANY(sv));
4711 SvFLAGS(sv) &= SVf_BREAK;
4712 SvFLAGS(sv) |= SVTYPEMASK;
4716 Perl_sv_newref(pTHX_ SV *sv)
4719 ATOMIC_INC(SvREFCNT(sv));
4726 Free the memory used by an SV.
4732 Perl_sv_free(pTHX_ SV *sv)
4734 int refcount_is_zero;
4738 if (SvREFCNT(sv) == 0) {
4739 if (SvFLAGS(sv) & SVf_BREAK)
4741 if (PL_in_clean_all) /* All is fair */
4743 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4744 /* make sure SvREFCNT(sv)==0 happens very seldom */
4745 SvREFCNT(sv) = (~(U32)0)/2;
4748 if (ckWARN_d(WARN_INTERNAL))
4749 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4752 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4753 if (!refcount_is_zero)
4757 if (ckWARN_d(WARN_DEBUGGING))
4758 Perl_warner(aTHX_ WARN_DEBUGGING,
4759 "Attempt to free temp prematurely: SV 0x%"UVxf,
4764 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4765 /* make sure SvREFCNT(sv)==0 happens very seldom */
4766 SvREFCNT(sv) = (~(U32)0)/2;
4777 Returns the length of the string in the SV. See also C<SvCUR>.
4783 Perl_sv_len(pTHX_ register SV *sv)
4792 len = mg_length(sv);
4794 junk = SvPV(sv, len);
4799 =for apidoc sv_len_utf8
4801 Returns the number of characters in the string in an SV, counting wide
4802 UTF8 bytes as a single character.
4808 Perl_sv_len_utf8(pTHX_ register SV *sv)
4814 return mg_length(sv);
4818 U8 *s = (U8*)SvPV(sv, len);
4820 return Perl_utf8_length(aTHX_ s, s + len);
4825 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4830 I32 uoffset = *offsetp;
4836 start = s = (U8*)SvPV(sv, len);
4838 while (s < send && uoffset--)
4842 *offsetp = s - start;
4846 while (s < send && ulen--)
4856 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4865 s = (U8*)SvPV(sv, len);
4867 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4868 send = s + *offsetp;
4872 /* Call utf8n_to_uvchr() to validate the sequence */
4873 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4888 Returns a boolean indicating whether the strings in the two SVs are
4895 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4909 pv1 = SvPV(sv1, cur1);
4916 pv2 = SvPV(sv2, cur2);
4918 /* do not utf8ize the comparands as a side-effect */
4919 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4920 bool is_utf8 = TRUE;
4921 /* UTF-8ness differs */
4922 if (PL_hints & HINT_UTF8_DISTINCT)
4926 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4927 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4932 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4933 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4938 /* Downgrade not possible - cannot be eq */
4944 eq = memEQ(pv1, pv2, cur1);
4955 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4956 string in C<sv1> is less than, equal to, or greater than the string in
4963 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4968 bool pv1tmp = FALSE;
4969 bool pv2tmp = FALSE;
4976 pv1 = SvPV(sv1, cur1);
4983 pv2 = SvPV(sv2, cur2);
4985 /* do not utf8ize the comparands as a side-effect */
4986 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4987 if (PL_hints & HINT_UTF8_DISTINCT)
4988 return SvUTF8(sv1) ? 1 : -1;
4991 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4995 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
5001 cmp = cur2 ? -1 : 0;
5005 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
5008 cmp = retval < 0 ? -1 : 1;
5009 } else if (cur1 == cur2) {
5012 cmp = cur1 < cur2 ? -1 : 1;
5025 =for apidoc sv_cmp_locale
5027 Compares the strings in two SVs in a locale-aware manner. See
5034 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5036 #ifdef USE_LOCALE_COLLATE
5042 if (PL_collation_standard)
5046 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5048 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5050 if (!pv1 || !len1) {
5061 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5064 return retval < 0 ? -1 : 1;
5067 * When the result of collation is equality, that doesn't mean
5068 * that there are no differences -- some locales exclude some
5069 * characters from consideration. So to avoid false equalities,
5070 * we use the raw string as a tiebreaker.
5076 #endif /* USE_LOCALE_COLLATE */
5078 return sv_cmp(sv1, sv2);
5081 #ifdef USE_LOCALE_COLLATE
5083 * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5084 * scalar data of the variable transformed to such a format that
5085 * a normal memory comparison can be used to compare the data
5086 * according to the locale settings.
5089 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5093 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5094 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5099 Safefree(mg->mg_ptr);
5101 if ((xf = mem_collxfrm(s, len, &xlen))) {
5102 if (SvREADONLY(sv)) {
5105 return xf + sizeof(PL_collation_ix);
5108 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5109 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5122 if (mg && mg->mg_ptr) {
5124 return mg->mg_ptr + sizeof(PL_collation_ix);
5132 #endif /* USE_LOCALE_COLLATE */
5137 Get a line from the filehandle and store it into the SV, optionally
5138 appending to the currently-stored string.
5144 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5148 register STDCHAR rslast;
5149 register STDCHAR *bp;
5153 SV_CHECK_THINKFIRST(sv);
5154 (void)SvUPGRADE(sv, SVt_PV);
5158 if (RsSNARF(PL_rs)) {
5162 else if (RsRECORD(PL_rs)) {
5163 I32 recsize, bytesread;
5166 /* Grab the size of the record we're getting */
5167 recsize = SvIV(SvRV(PL_rs));
5168 (void)SvPOK_only(sv); /* Validate pointer */
5169 buffer = SvGROW(sv, recsize + 1);
5172 /* VMS wants read instead of fread, because fread doesn't respect */
5173 /* RMS record boundaries. This is not necessarily a good thing to be */
5174 /* doing, but we've got no other real choice */
5175 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5177 bytesread = PerlIO_read(fp, buffer, recsize);
5179 SvCUR_set(sv, bytesread);
5180 buffer[bytesread] = '\0';
5181 if (PerlIO_isutf8(fp))
5185 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5187 else if (RsPARA(PL_rs)) {
5192 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5193 if (PerlIO_isutf8(fp)) {
5194 rsptr = SvPVutf8(PL_rs, rslen);
5197 if (SvUTF8(PL_rs)) {
5198 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5199 Perl_croak(aTHX_ "Wide character in $/");
5202 rsptr = SvPV(PL_rs, rslen);
5206 rslast = rslen ? rsptr[rslen - 1] : '\0';
5208 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5209 do { /* to make sure file boundaries work right */
5212 i = PerlIO_getc(fp);
5216 PerlIO_ungetc(fp,i);
5222 /* See if we know enough about I/O mechanism to cheat it ! */
5224 /* This used to be #ifdef test - it is made run-time test for ease
5225 of abstracting out stdio interface. One call should be cheap
5226 enough here - and may even be a macro allowing compile
5230 if (PerlIO_fast_gets(fp)) {
5233 * We're going to steal some values from the stdio struct
5234 * and put EVERYTHING in the innermost loop into registers.
5236 register STDCHAR *ptr;
5240 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5241 /* An ungetc()d char is handled separately from the regular
5242 * buffer, so we getc() it back out and stuff it in the buffer.
5244 i = PerlIO_getc(fp);
5245 if (i == EOF) return 0;
5246 *(--((*fp)->_ptr)) = (unsigned char) i;
5250 /* Here is some breathtakingly efficient cheating */
5252 cnt = PerlIO_get_cnt(fp); /* get count into register */
5253 (void)SvPOK_only(sv); /* validate pointer */
5254 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5255 if (cnt > 80 && SvLEN(sv) > append) {
5256 shortbuffered = cnt - SvLEN(sv) + append + 1;
5257 cnt -= shortbuffered;
5261 /* remember that cnt can be negative */
5262 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5267 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5268 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5269 DEBUG_P(PerlIO_printf(Perl_debug_log,
5270 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5271 DEBUG_P(PerlIO_printf(Perl_debug_log,
5272 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5273 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5274 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5279 while (cnt > 0) { /* this | eat */
5281 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5282 goto thats_all_folks; /* screams | sed :-) */
5286 Copy(ptr, bp, cnt, char); /* this | eat */
5287 bp += cnt; /* screams | dust */
5288 ptr += cnt; /* louder | sed :-) */
5293 if (shortbuffered) { /* oh well, must extend */
5294 cnt = shortbuffered;
5296 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5298 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5299 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5303 DEBUG_P(PerlIO_printf(Perl_debug_log,
5304 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5305 PTR2UV(ptr),(long)cnt));
5306 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5307 DEBUG_P(PerlIO_printf(Perl_debug_log,
5308 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5309 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5310 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5311 /* This used to call 'filbuf' in stdio form, but as that behaves like
5312 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5313 another abstraction. */
5314 i = PerlIO_getc(fp); /* get more characters */
5315 DEBUG_P(PerlIO_printf(Perl_debug_log,
5316 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5317 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5318 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5319 cnt = PerlIO_get_cnt(fp);
5320 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5321 DEBUG_P(PerlIO_printf(Perl_debug_log,
5322 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5324 if (i == EOF) /* all done for ever? */
5325 goto thats_really_all_folks;
5327 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5329 SvGROW(sv, bpx + cnt + 2);
5330 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5332 *bp++ = i; /* store character from PerlIO_getc */
5334 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5335 goto thats_all_folks;
5339 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5340 memNE((char*)bp - rslen, rsptr, rslen))
5341 goto screamer; /* go back to the fray */
5342 thats_really_all_folks:
5344 cnt += shortbuffered;
5345 DEBUG_P(PerlIO_printf(Perl_debug_log,
5346 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5347 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5348 DEBUG_P(PerlIO_printf(Perl_debug_log,
5349 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5350 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5351 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5353 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5354 DEBUG_P(PerlIO_printf(Perl_debug_log,
5355 "Screamer: done, len=%ld, string=|%.*s|\n",
5356 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5361 /*The big, slow, and stupid way */
5364 /* Need to work around EPOC SDK features */
5365 /* On WINS: MS VC5 generates calls to _chkstk, */
5366 /* if a `large' stack frame is allocated */
5367 /* gcc on MARM does not generate calls like these */
5373 register STDCHAR *bpe = buf + sizeof(buf);
5375 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5376 ; /* keep reading */
5380 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5381 /* Accomodate broken VAXC compiler, which applies U8 cast to
5382 * both args of ?: operator, causing EOF to change into 255
5384 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5388 sv_catpvn(sv, (char *) buf, cnt);
5390 sv_setpvn(sv, (char *) buf, cnt);
5392 if (i != EOF && /* joy */
5394 SvCUR(sv) < rslen ||
5395 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5399 * If we're reading from a TTY and we get a short read,
5400 * indicating that the user hit his EOF character, we need
5401 * to notice it now, because if we try to read from the TTY
5402 * again, the EOF condition will disappear.
5404 * The comparison of cnt to sizeof(buf) is an optimization
5405 * that prevents unnecessary calls to feof().
5409 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5414 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5415 while (i != EOF) { /* to make sure file boundaries work right */
5416 i = PerlIO_getc(fp);
5418 PerlIO_ungetc(fp,i);
5424 if (PerlIO_isutf8(fp))
5429 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5436 Auto-increment of the value in the SV.
5442 Perl_sv_inc(pTHX_ register SV *sv)
5451 if (SvTHINKFIRST(sv)) {
5452 if (SvREADONLY(sv)) {
5453 if (PL_curcop != &PL_compiling)
5454 Perl_croak(aTHX_ PL_no_modify);
5458 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5460 i = PTR2IV(SvRV(sv));
5465 flags = SvFLAGS(sv);
5466 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5467 /* It's (privately or publicly) a float, but not tested as an
5468 integer, so test it to see. */
5470 flags = SvFLAGS(sv);
5472 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5473 /* It's publicly an integer, or privately an integer-not-float */
5476 if (SvUVX(sv) == UV_MAX)
5477 sv_setnv(sv, (NV)UV_MAX + 1.0);
5479 (void)SvIOK_only_UV(sv);
5482 if (SvIVX(sv) == IV_MAX)
5483 sv_setuv(sv, (UV)IV_MAX + 1);
5485 (void)SvIOK_only(sv);
5491 if (flags & SVp_NOK) {
5492 (void)SvNOK_only(sv);
5497 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5498 if ((flags & SVTYPEMASK) < SVt_PVIV)
5499 sv_upgrade(sv, SVt_IV);
5500 (void)SvIOK_only(sv);
5505 while (isALPHA(*d)) d++;
5506 while (isDIGIT(*d)) d++;
5508 #ifdef PERL_PRESERVE_IVUV
5509 /* Got to punt this an an integer if needs be, but we don't issue
5510 warnings. Probably ought to make the sv_iv_please() that does
5511 the conversion if possible, and silently. */
5512 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5513 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5514 /* Need to try really hard to see if it's an integer.
5515 9.22337203685478e+18 is an integer.
5516 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5517 so $a="9.22337203685478e+18"; $a+0; $a++
5518 needs to be the same as $a="9.22337203685478e+18"; $a++
5525 /* sv_2iv *should* have made this an NV */
5526 if (flags & SVp_NOK) {
5527 (void)SvNOK_only(sv);
5531 /* I don't think we can get here. Maybe I should assert this
5532 And if we do get here I suspect that sv_setnv will croak. NWC
5534 #if defined(USE_LONG_DOUBLE)
5535 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",
5536 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5538 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5539 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5542 #endif /* PERL_PRESERVE_IVUV */
5543 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5547 while (d >= SvPVX(sv)) {
5555 /* MKS: The original code here died if letters weren't consecutive.
5556 * at least it didn't have to worry about non-C locales. The
5557 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5558 * arranged in order (although not consecutively) and that only
5559 * [A-Za-z] are accepted by isALPHA in the C locale.
5561 if (*d != 'z' && *d != 'Z') {
5562 do { ++*d; } while (!isALPHA(*d));
5565 *(d--) -= 'z' - 'a';
5570 *(d--) -= 'z' - 'a' + 1;
5574 /* oh,oh, the number grew */
5575 SvGROW(sv, SvCUR(sv) + 2);
5577 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5588 Auto-decrement of the value in the SV.
5594 Perl_sv_dec(pTHX_ register SV *sv)
5602 if (SvTHINKFIRST(sv)) {
5603 if (SvREADONLY(sv)) {
5604 if (PL_curcop != &PL_compiling)
5605 Perl_croak(aTHX_ PL_no_modify);
5609 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5611 i = PTR2IV(SvRV(sv));
5616 /* Unlike sv_inc we don't have to worry about string-never-numbers
5617 and keeping them magic. But we mustn't warn on punting */
5618 flags = SvFLAGS(sv);
5619 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5620 /* It's publicly an integer, or privately an integer-not-float */
5623 if (SvUVX(sv) == 0) {
5624 (void)SvIOK_only(sv);
5628 (void)SvIOK_only_UV(sv);
5632 if (SvIVX(sv) == IV_MIN)
5633 sv_setnv(sv, (NV)IV_MIN - 1.0);
5635 (void)SvIOK_only(sv);
5641 if (flags & SVp_NOK) {
5643 (void)SvNOK_only(sv);
5646 if (!(flags & SVp_POK)) {
5647 if ((flags & SVTYPEMASK) < SVt_PVNV)
5648 sv_upgrade(sv, SVt_NV);
5650 (void)SvNOK_only(sv);
5653 #ifdef PERL_PRESERVE_IVUV
5655 int numtype = grok_number(SvPVX(sv), SvCUR(sv), NULL);
5656 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5657 /* Need to try really hard to see if it's an integer.
5658 9.22337203685478e+18 is an integer.
5659 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5660 so $a="9.22337203685478e+18"; $a+0; $a--
5661 needs to be the same as $a="9.22337203685478e+18"; $a--
5668 /* sv_2iv *should* have made this an NV */
5669 if (flags & SVp_NOK) {
5670 (void)SvNOK_only(sv);
5674 /* I don't think we can get here. Maybe I should assert this
5675 And if we do get here I suspect that sv_setnv will croak. NWC
5677 #if defined(USE_LONG_DOUBLE)
5678 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",
5679 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5681 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5682 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5686 #endif /* PERL_PRESERVE_IVUV */
5687 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5691 =for apidoc sv_mortalcopy
5693 Creates a new SV which is a copy of the original SV. The new SV is marked
5699 /* Make a string that will exist for the duration of the expression
5700 * evaluation. Actually, it may have to last longer than that, but
5701 * hopefully we won't free it until it has been assigned to a
5702 * permanent location. */
5705 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5710 sv_setsv(sv,oldstr);
5712 PL_tmps_stack[++PL_tmps_ix] = sv;
5718 =for apidoc sv_newmortal
5720 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5726 Perl_sv_newmortal(pTHX)
5731 SvFLAGS(sv) = SVs_TEMP;
5733 PL_tmps_stack[++PL_tmps_ix] = sv;
5738 =for apidoc sv_2mortal
5740 Marks an SV as mortal. The SV will be destroyed when the current context
5746 /* same thing without the copying */
5749 Perl_sv_2mortal(pTHX_ register SV *sv)
5753 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5756 PL_tmps_stack[++PL_tmps_ix] = sv;
5764 Creates a new SV and copies a string into it. The reference count for the
5765 SV is set to 1. If C<len> is zero, Perl will compute the length using
5766 strlen(). For efficiency, consider using C<newSVpvn> instead.
5772 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5779 sv_setpvn(sv,s,len);
5784 =for apidoc newSVpvn
5786 Creates a new SV and copies a string into it. The reference count for the
5787 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5788 string. You are responsible for ensuring that the source string is at least
5795 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5800 sv_setpvn(sv,s,len);
5805 =for apidoc newSVpvn_share
5807 Creates a new SV and populates it with a string from
5808 the string table. Turns on READONLY and FAKE.
5809 The idea here is that as string table is used for shared hash
5810 keys these strings will have SvPVX == HeKEY and hash lookup
5811 will avoid string compare.
5817 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5820 bool is_utf8 = FALSE;
5825 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5826 STRLEN tmplen = len;
5827 /* See the note in hv.c:hv_fetch() --jhi */
5828 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5832 PERL_HASH(hash, src, len);
5834 sv_upgrade(sv, SVt_PVIV);
5835 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5847 #if defined(PERL_IMPLICIT_CONTEXT)
5849 Perl_newSVpvf_nocontext(const char* pat, ...)
5854 va_start(args, pat);
5855 sv = vnewSVpvf(pat, &args);
5862 =for apidoc newSVpvf
5864 Creates a new SV an initialize it with the string formatted like
5871 Perl_newSVpvf(pTHX_ const char* pat, ...)
5875 va_start(args, pat);
5876 sv = vnewSVpvf(pat, &args);
5882 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5886 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5893 Creates a new SV and copies a floating point value into it.
5894 The reference count for the SV is set to 1.
5900 Perl_newSVnv(pTHX_ NV n)
5912 Creates a new SV and copies an integer into it. The reference count for the
5919 Perl_newSViv(pTHX_ IV i)
5931 Creates a new SV and copies an unsigned integer into it.
5932 The reference count for the SV is set to 1.
5938 Perl_newSVuv(pTHX_ UV u)
5948 =for apidoc newRV_noinc
5950 Creates an RV wrapper for an SV. The reference count for the original
5951 SV is B<not> incremented.
5957 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5962 sv_upgrade(sv, SVt_RV);
5969 /* newRV_inc is #defined to newRV in sv.h */
5971 Perl_newRV(pTHX_ SV *tmpRef)
5973 return newRV_noinc(SvREFCNT_inc(tmpRef));
5979 Creates a new SV which is an exact duplicate of the original SV.
5984 /* make an exact duplicate of old */
5987 Perl_newSVsv(pTHX_ register SV *old)
5993 if (SvTYPE(old) == SVTYPEMASK) {
5994 if (ckWARN_d(WARN_INTERNAL))
5995 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
6010 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6018 char todo[PERL_UCHAR_MAX+1];
6023 if (!*s) { /* reset ?? searches */
6024 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6025 pm->op_pmdynflags &= ~PMdf_USED;
6030 /* reset variables */
6032 if (!HvARRAY(stash))
6035 Zero(todo, 256, char);
6037 i = (unsigned char)*s;
6041 max = (unsigned char)*s++;
6042 for ( ; i <= max; i++) {
6045 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6046 for (entry = HvARRAY(stash)[i];
6048 entry = HeNEXT(entry))
6050 if (!todo[(U8)*HeKEY(entry)])
6052 gv = (GV*)HeVAL(entry);
6054 if (SvTHINKFIRST(sv)) {
6055 if (!SvREADONLY(sv) && SvROK(sv))
6060 if (SvTYPE(sv) >= SVt_PV) {
6062 if (SvPVX(sv) != Nullch)
6069 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6071 #ifdef USE_ENVIRON_ARRAY
6073 environ[0] = Nullch;
6082 Perl_sv_2io(pTHX_ SV *sv)
6088 switch (SvTYPE(sv)) {
6096 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6100 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6102 return sv_2io(SvRV(sv));
6103 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6109 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6116 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6123 return *gvp = Nullgv, Nullcv;
6124 switch (SvTYPE(sv)) {
6143 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6144 tryAMAGICunDEREF(to_cv);
6147 if (SvTYPE(sv) == SVt_PVCV) {
6156 Perl_croak(aTHX_ "Not a subroutine reference");
6161 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6167 if (lref && !GvCVu(gv)) {
6170 tmpsv = NEWSV(704,0);
6171 gv_efullname3(tmpsv, gv, Nullch);
6172 /* XXX this is probably not what they think they're getting.
6173 * It has the same effect as "sub name;", i.e. just a forward
6175 newSUB(start_subparse(FALSE, 0),
6176 newSVOP(OP_CONST, 0, tmpsv),
6181 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6190 Returns true if the SV has a true value by Perl's rules.
6196 Perl_sv_true(pTHX_ register SV *sv)
6202 if ((tXpv = (XPV*)SvANY(sv)) &&
6203 (tXpv->xpv_cur > 1 ||
6204 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6211 return SvIVX(sv) != 0;
6214 return SvNVX(sv) != 0.0;
6216 return sv_2bool(sv);
6222 Perl_sv_iv(pTHX_ register SV *sv)
6226 return (IV)SvUVX(sv);
6233 Perl_sv_uv(pTHX_ register SV *sv)
6238 return (UV)SvIVX(sv);
6244 Perl_sv_nv(pTHX_ register SV *sv)
6252 Perl_sv_pv(pTHX_ SV *sv)
6259 return sv_2pv(sv, &n_a);
6263 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6269 return sv_2pv(sv, lp);
6273 =for apidoc sv_pvn_force
6275 Get a sensible string out of the SV somehow.
6281 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6283 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6287 =for apidoc sv_pvn_force_flags
6289 Get a sensible string out of the SV somehow.
6290 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6291 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6292 implemented in terms of this function.
6298 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6302 if (SvTHINKFIRST(sv) && !SvROK(sv))
6303 sv_force_normal(sv);
6309 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6310 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6311 PL_op_name[PL_op->op_type]);
6314 s = sv_2pv_flags(sv, lp, flags);
6315 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6320 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6321 SvGROW(sv, len + 1);
6322 Move(s,SvPVX(sv),len,char);
6327 SvPOK_on(sv); /* validate pointer */
6329 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6330 PTR2UV(sv),SvPVX(sv)));
6337 Perl_sv_pvbyte(pTHX_ SV *sv)
6339 sv_utf8_downgrade(sv,0);
6344 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6346 sv_utf8_downgrade(sv,0);
6347 return sv_pvn(sv,lp);
6351 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6353 sv_utf8_downgrade(sv,0);
6354 return sv_pvn_force(sv,lp);
6358 Perl_sv_pvutf8(pTHX_ SV *sv)
6360 sv_utf8_upgrade(sv);
6365 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6367 sv_utf8_upgrade(sv);
6368 return sv_pvn(sv,lp);
6372 =for apidoc sv_pvutf8n_force
6374 Get a sensible UTF8-encoded string out of the SV somehow. See
6381 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6383 sv_utf8_upgrade(sv);
6384 return sv_pvn_force(sv,lp);
6388 =for apidoc sv_reftype
6390 Returns a string describing what the SV is a reference to.
6396 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6398 if (ob && SvOBJECT(sv))
6399 return HvNAME(SvSTASH(sv));
6401 switch (SvTYPE(sv)) {
6415 case SVt_PVLV: return "LVALUE";
6416 case SVt_PVAV: return "ARRAY";
6417 case SVt_PVHV: return "HASH";
6418 case SVt_PVCV: return "CODE";
6419 case SVt_PVGV: return "GLOB";
6420 case SVt_PVFM: return "FORMAT";
6421 case SVt_PVIO: return "IO";
6422 default: return "UNKNOWN";
6428 =for apidoc sv_isobject
6430 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6431 object. If the SV is not an RV, or if the object is not blessed, then this
6438 Perl_sv_isobject(pTHX_ SV *sv)
6455 Returns a boolean indicating whether the SV is blessed into the specified
6456 class. This does not check for subtypes; use C<sv_derived_from> to verify
6457 an inheritance relationship.
6463 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6475 return strEQ(HvNAME(SvSTASH(sv)), name);
6481 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6482 it will be upgraded to one. If C<classname> is non-null then the new SV will
6483 be blessed in the specified package. The new SV is returned and its
6484 reference count is 1.
6490 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6496 SV_CHECK_THINKFIRST(rv);
6499 if (SvTYPE(rv) >= SVt_PVMG) {
6500 U32 refcnt = SvREFCNT(rv);
6504 SvREFCNT(rv) = refcnt;
6507 if (SvTYPE(rv) < SVt_RV)
6508 sv_upgrade(rv, SVt_RV);
6509 else if (SvTYPE(rv) > SVt_RV) {
6510 (void)SvOOK_off(rv);
6511 if (SvPVX(rv) && SvLEN(rv))
6512 Safefree(SvPVX(rv));
6522 HV* stash = gv_stashpv(classname, TRUE);
6523 (void)sv_bless(rv, stash);
6529 =for apidoc sv_setref_pv
6531 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6532 argument will be upgraded to an RV. That RV will be modified to point to
6533 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6534 into the SV. The C<classname> argument indicates the package for the
6535 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6536 will be returned and will have a reference count of 1.
6538 Do not use with other Perl types such as HV, AV, SV, CV, because those
6539 objects will become corrupted by the pointer copy process.
6541 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6547 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6550 sv_setsv(rv, &PL_sv_undef);
6554 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6559 =for apidoc sv_setref_iv
6561 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6562 argument will be upgraded to an RV. That RV will be modified to point to
6563 the new SV. The C<classname> argument indicates the package for the
6564 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6565 will be returned and will have a reference count of 1.
6571 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6573 sv_setiv(newSVrv(rv,classname), iv);
6578 =for apidoc sv_setref_uv
6580 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6581 argument will be upgraded to an RV. That RV will be modified to point to
6582 the new SV. The C<classname> argument indicates the package for the
6583 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6584 will be returned and will have a reference count of 1.
6590 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6592 sv_setuv(newSVrv(rv,classname), uv);
6597 =for apidoc sv_setref_nv
6599 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6600 argument will be upgraded to an RV. That RV will be modified to point to
6601 the new SV. The C<classname> argument indicates the package for the
6602 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6603 will be returned and will have a reference count of 1.
6609 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6611 sv_setnv(newSVrv(rv,classname), nv);
6616 =for apidoc sv_setref_pvn
6618 Copies a string into a new SV, optionally blessing the SV. The length of the
6619 string must be specified with C<n>. The C<rv> argument will be upgraded to
6620 an RV. That RV will be modified to point to the new SV. The C<classname>
6621 argument indicates the package for the blessing. Set C<classname> to
6622 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6623 a reference count of 1.
6625 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6631 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6633 sv_setpvn(newSVrv(rv,classname), pv, n);
6638 =for apidoc sv_bless
6640 Blesses an SV into a specified package. The SV must be an RV. The package
6641 must be designated by its stash (see C<gv_stashpv()>). The reference count
6642 of the SV is unaffected.
6648 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6652 Perl_croak(aTHX_ "Can't bless non-reference value");
6654 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6655 if (SvREADONLY(tmpRef))
6656 Perl_croak(aTHX_ PL_no_modify);
6657 if (SvOBJECT(tmpRef)) {
6658 if (SvTYPE(tmpRef) != SVt_PVIO)
6660 SvREFCNT_dec(SvSTASH(tmpRef));
6663 SvOBJECT_on(tmpRef);
6664 if (SvTYPE(tmpRef) != SVt_PVIO)
6666 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6667 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6678 S_sv_unglob(pTHX_ SV *sv)
6682 assert(SvTYPE(sv) == SVt_PVGV);
6687 SvREFCNT_dec(GvSTASH(sv));
6688 GvSTASH(sv) = Nullhv;
6690 sv_unmagic(sv, PERL_MAGIC_glob);
6691 Safefree(GvNAME(sv));
6694 /* need to keep SvANY(sv) in the right arena */
6695 xpvmg = new_XPVMG();
6696 StructCopy(SvANY(sv), xpvmg, XPVMG);
6697 del_XPVGV(SvANY(sv));
6700 SvFLAGS(sv) &= ~SVTYPEMASK;
6701 SvFLAGS(sv) |= SVt_PVMG;
6705 =for apidoc sv_unref_flags
6707 Unsets the RV status of the SV, and decrements the reference count of
6708 whatever was being referenced by the RV. This can almost be thought of
6709 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6710 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6711 (otherwise the decrementing is conditional on the reference count being
6712 different from one or the reference being a readonly SV).
6719 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6723 if (SvWEAKREF(sv)) {
6731 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6733 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6734 sv_2mortal(rv); /* Schedule for freeing later */
6738 =for apidoc sv_unref
6740 Unsets the RV status of the SV, and decrements the reference count of
6741 whatever was being referenced by the RV. This can almost be thought of
6742 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6743 being zero. See C<SvROK_off>.
6749 Perl_sv_unref(pTHX_ SV *sv)
6751 sv_unref_flags(sv, 0);
6755 Perl_sv_taint(pTHX_ SV *sv)
6757 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
6761 Perl_sv_untaint(pTHX_ SV *sv)
6763 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6764 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6771 Perl_sv_tainted(pTHX_ SV *sv)
6773 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6774 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6775 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6782 =for apidoc sv_setpviv
6784 Copies an integer into the given SV, also updating its string value.
6785 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6791 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6793 char buf[TYPE_CHARS(UV)];
6795 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6797 sv_setpvn(sv, ptr, ebuf - ptr);
6802 =for apidoc sv_setpviv_mg
6804 Like C<sv_setpviv>, but also handles 'set' magic.
6810 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6812 char buf[TYPE_CHARS(UV)];
6814 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6816 sv_setpvn(sv, ptr, ebuf - ptr);
6820 #if defined(PERL_IMPLICIT_CONTEXT)
6822 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6826 va_start(args, pat);
6827 sv_vsetpvf(sv, pat, &args);
6833 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6837 va_start(args, pat);
6838 sv_vsetpvf_mg(sv, pat, &args);
6844 =for apidoc sv_setpvf
6846 Processes its arguments like C<sprintf> and sets an SV to the formatted
6847 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6853 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6856 va_start(args, pat);
6857 sv_vsetpvf(sv, pat, &args);
6862 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6864 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6868 =for apidoc sv_setpvf_mg
6870 Like C<sv_setpvf>, but also handles 'set' magic.
6876 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6879 va_start(args, pat);
6880 sv_vsetpvf_mg(sv, pat, &args);
6885 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6887 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6891 #if defined(PERL_IMPLICIT_CONTEXT)
6893 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6897 va_start(args, pat);
6898 sv_vcatpvf(sv, pat, &args);
6903 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6907 va_start(args, pat);
6908 sv_vcatpvf_mg(sv, pat, &args);
6914 =for apidoc sv_catpvf
6916 Processes its arguments like C<sprintf> and appends the formatted
6917 output to an SV. If the appended data contains "wide" characters
6918 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6919 and characters >255 formatted with %c), the original SV might get
6920 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6921 C<SvSETMAGIC()> must typically be called after calling this function
6922 to handle 'set' magic.
6927 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6930 va_start(args, pat);
6931 sv_vcatpvf(sv, pat, &args);
6936 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6938 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6942 =for apidoc sv_catpvf_mg
6944 Like C<sv_catpvf>, but also handles 'set' magic.
6950 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6953 va_start(args, pat);
6954 sv_vcatpvf_mg(sv, pat, &args);
6959 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6961 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6966 =for apidoc sv_vsetpvfn
6968 Works like C<vcatpvfn> but copies the text into the SV instead of
6975 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6977 sv_setpvn(sv, "", 0);
6978 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6982 S_expect_number(pTHX_ char** pattern)
6985 switch (**pattern) {
6986 case '1': case '2': case '3':
6987 case '4': case '5': case '6':
6988 case '7': case '8': case '9':
6989 while (isDIGIT(**pattern))
6990 var = var * 10 + (*(*pattern)++ - '0');
6994 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6997 =for apidoc sv_vcatpvfn
6999 Processes its arguments like C<vsprintf> and appends the formatted output
7000 to an SV. Uses an array of SVs if the C style variable argument list is
7001 missing (NULL). When running with taint checks enabled, indicates via
7002 C<maybe_tainted> if results are untrustworthy (often due to the use of
7009 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
7016 static char nullstr[] = "(null)";
7019 /* no matter what, this is a string now */
7020 (void)SvPV_force(sv, origlen);
7022 /* special-case "", "%s", and "%_" */
7025 if (patlen == 2 && pat[0] == '%') {
7029 char *s = va_arg(*args, char*);
7030 sv_catpv(sv, s ? s : nullstr);
7032 else if (svix < svmax) {
7033 sv_catsv(sv, *svargs);
7034 if (DO_UTF8(*svargs))
7040 argsv = va_arg(*args, SV*);
7041 sv_catsv(sv, argsv);
7046 /* See comment on '_' below */
7051 patend = (char*)pat + patlen;
7052 for (p = (char*)pat; p < patend; p = q) {
7055 bool vectorize = FALSE;
7056 bool vectorarg = FALSE;
7057 bool vec_utf = FALSE;
7063 bool has_precis = FALSE;
7065 bool is_utf = FALSE;
7068 U8 utf8buf[UTF8_MAXLEN+1];
7069 STRLEN esignlen = 0;
7071 char *eptr = Nullch;
7073 /* Times 4: a decimal digit takes more than 3 binary digits.
7074 * NV_DIG: mantissa takes than many decimal digits.
7075 * Plus 32: Playing safe. */
7076 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7077 /* large enough for "%#.#f" --chip */
7078 /* what about long double NVs? --jhi */
7081 U8 *vecstr = Null(U8*);
7093 STRLEN dotstrlen = 1;
7094 I32 efix = 0; /* explicit format parameter index */
7095 I32 ewix = 0; /* explicit width index */
7096 I32 epix = 0; /* explicit precision index */
7097 I32 evix = 0; /* explicit vector index */
7098 bool asterisk = FALSE;
7100 /* echo everything up to the next format specification */
7101 for (q = p; q < patend && *q != '%'; ++q) ;
7103 sv_catpvn(sv, p, q - p);
7110 We allow format specification elements in this order:
7111 \d+\$ explicit format parameter index
7113 \*?(\d+\$)?v vector with optional (optionally specified) arg
7114 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7115 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7117 [%bcdefginopsux_DFOUX] format (mandatory)
7119 if (EXPECT_NUMBER(q, width)) {
7160 if (EXPECT_NUMBER(q, ewix))
7169 if ((vectorarg = asterisk)) {
7179 EXPECT_NUMBER(q, width);
7184 vecsv = va_arg(*args, SV*);
7186 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7187 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7188 dotstr = SvPVx(vecsv, dotstrlen);
7193 vecsv = va_arg(*args, SV*);
7194 vecstr = (U8*)SvPVx(vecsv,veclen);
7195 vec_utf = DO_UTF8(vecsv);
7197 else if (efix ? efix <= svmax : svix < svmax) {
7198 vecsv = svargs[efix ? efix-1 : svix++];
7199 vecstr = (U8*)SvPVx(vecsv,veclen);
7200 vec_utf = DO_UTF8(vecsv);
7210 i = va_arg(*args, int);
7212 i = (ewix ? ewix <= svmax : svix < svmax) ?
7213 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7215 width = (i < 0) ? -i : i;
7225 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7228 i = va_arg(*args, int);
7230 i = (ewix ? ewix <= svmax : svix < svmax)
7231 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7232 precis = (i < 0) ? 0 : i;
7237 precis = precis * 10 + (*q++ - '0');
7245 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7256 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7257 if (*(q + 1) == 'l') { /* lld, llf */
7280 argsv = (efix ? efix <= svmax : svix < svmax) ?
7281 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7288 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7290 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7292 eptr = (char*)utf8buf;
7293 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7305 eptr = va_arg(*args, char*);
7307 #ifdef MACOS_TRADITIONAL
7308 /* On MacOS, %#s format is used for Pascal strings */
7313 elen = strlen(eptr);
7316 elen = sizeof nullstr - 1;
7320 eptr = SvPVx(argsv, elen);
7321 if (DO_UTF8(argsv)) {
7322 if (has_precis && precis < elen) {
7324 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7327 if (width) { /* fudge width (can't fudge elen) */
7328 width += elen - sv_len_utf8(argsv);
7337 * The "%_" hack might have to be changed someday,
7338 * if ISO or ANSI decide to use '_' for something.
7339 * So we keep it hidden from users' code.
7343 argsv = va_arg(*args, SV*);
7344 eptr = SvPVx(argsv, elen);
7350 if (has_precis && elen > precis)
7359 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7377 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7387 case 'h': iv = (short)va_arg(*args, int); break;
7388 default: iv = va_arg(*args, int); break;
7389 case 'l': iv = va_arg(*args, long); break;
7390 case 'V': iv = va_arg(*args, IV); break;
7392 case 'q': iv = va_arg(*args, Quad_t); break;
7399 case 'h': iv = (short)iv; break;
7401 case 'l': iv = (long)iv; break;
7404 case 'q': iv = (Quad_t)iv; break;
7411 esignbuf[esignlen++] = plus;
7415 esignbuf[esignlen++] = '-';
7457 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7467 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7468 default: uv = va_arg(*args, unsigned); break;
7469 case 'l': uv = va_arg(*args, unsigned long); break;
7470 case 'V': uv = va_arg(*args, UV); break;
7472 case 'q': uv = va_arg(*args, Quad_t); break;
7479 case 'h': uv = (unsigned short)uv; break;
7481 case 'l': uv = (unsigned long)uv; break;
7484 case 'q': uv = (Quad_t)uv; break;
7490 eptr = ebuf + sizeof ebuf;
7496 p = (char*)((c == 'X')
7497 ? "0123456789ABCDEF" : "0123456789abcdef");
7503 esignbuf[esignlen++] = '0';
7504 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7510 *--eptr = '0' + dig;
7512 if (alt && *eptr != '0')
7518 *--eptr = '0' + dig;
7521 esignbuf[esignlen++] = '0';
7522 esignbuf[esignlen++] = 'b';
7525 default: /* it had better be ten or less */
7526 #if defined(PERL_Y2KWARN)
7527 if (ckWARN(WARN_Y2K)) {
7529 char *s = SvPV(sv,n);
7530 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7531 && (n == 2 || !isDIGIT(s[n-3])))
7533 Perl_warner(aTHX_ WARN_Y2K,
7534 "Possible Y2K bug: %%%c %s",
7535 c, "format string following '19'");
7541 *--eptr = '0' + dig;
7542 } while (uv /= base);
7545 elen = (ebuf + sizeof ebuf) - eptr;
7548 zeros = precis - elen;
7549 else if (precis == 0 && elen == 1 && *eptr == '0')
7554 /* FLOATING POINT */
7557 c = 'f'; /* maybe %F isn't supported here */
7563 /* This is evil, but floating point is even more evil */
7566 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7569 if (c != 'e' && c != 'E') {
7571 (void)Perl_frexp(nv, &i);
7572 if (i == PERL_INT_MIN)
7573 Perl_die(aTHX_ "panic: frexp");
7575 need = BIT_DIGITS(i);
7577 need += has_precis ? precis : 6; /* known default */
7581 need += 20; /* fudge factor */
7582 if (PL_efloatsize < need) {
7583 Safefree(PL_efloatbuf);
7584 PL_efloatsize = need + 20; /* more fudge */
7585 New(906, PL_efloatbuf, PL_efloatsize, char);
7586 PL_efloatbuf[0] = '\0';
7589 eptr = ebuf + sizeof ebuf;
7592 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7594 /* Copy the one or more characters in a long double
7595 * format before the 'base' ([efgEFG]) character to
7596 * the format string. */
7597 static char const prifldbl[] = PERL_PRIfldbl;
7598 char const *p = prifldbl + sizeof(prifldbl) - 3;
7599 while (p >= prifldbl) { *--eptr = *p--; }
7604 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7609 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7621 /* No taint. Otherwise we are in the strange situation
7622 * where printf() taints but print($float) doesn't.
7624 (void)sprintf(PL_efloatbuf, eptr, nv);
7626 eptr = PL_efloatbuf;
7627 elen = strlen(PL_efloatbuf);
7634 i = SvCUR(sv) - origlen;
7637 case 'h': *(va_arg(*args, short*)) = i; break;
7638 default: *(va_arg(*args, int*)) = i; break;
7639 case 'l': *(va_arg(*args, long*)) = i; break;
7640 case 'V': *(va_arg(*args, IV*)) = i; break;
7642 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7647 sv_setuv_mg(argsv, (UV)i);
7648 continue; /* not "break" */
7655 if (!args && ckWARN(WARN_PRINTF) &&
7656 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7657 SV *msg = sv_newmortal();
7658 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7659 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7662 Perl_sv_catpvf(aTHX_ msg,
7663 "\"%%%c\"", c & 0xFF);
7665 Perl_sv_catpvf(aTHX_ msg,
7666 "\"%%\\%03"UVof"\"",
7669 sv_catpv(msg, "end of string");
7670 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7673 /* output mangled stuff ... */
7679 /* ... right here, because formatting flags should not apply */
7680 SvGROW(sv, SvCUR(sv) + elen + 1);
7682 Copy(eptr, p, elen, char);
7685 SvCUR(sv) = p - SvPVX(sv);
7686 continue; /* not "break" */
7689 have = esignlen + zeros + elen;
7690 need = (have > width ? have : width);
7693 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7695 if (esignlen && fill == '0') {
7696 for (i = 0; i < esignlen; i++)
7700 memset(p, fill, gap);
7703 if (esignlen && fill != '0') {
7704 for (i = 0; i < esignlen; i++)
7708 for (i = zeros; i; i--)
7712 Copy(eptr, p, elen, char);
7716 memset(p, ' ', gap);
7721 Copy(dotstr, p, dotstrlen, char);
7725 vectorize = FALSE; /* done iterating over vecstr */
7730 SvCUR(sv) = p - SvPVX(sv);
7738 #if defined(USE_ITHREADS)
7740 #if defined(USE_THREADS)
7741 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7744 #ifndef GpREFCNT_inc
7745 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7749 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7750 #define av_dup(s) (AV*)sv_dup((SV*)s)
7751 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7752 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7753 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7754 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7755 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7756 #define io_dup(s) (IO*)sv_dup((SV*)s)
7757 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7758 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7759 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7760 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7761 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7764 Perl_re_dup(pTHX_ REGEXP *r)
7766 /* XXX fix when pmop->op_pmregexp becomes shared */
7767 return ReREFCNT_inc(r);
7771 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7775 return (PerlIO*)NULL;
7777 /* look for it in the table first */
7778 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7782 /* create anew and remember what it is */
7783 ret = PerlIO_fdupopen(aTHX_ fp);
7784 ptr_table_store(PL_ptr_table, fp, ret);
7789 Perl_dirp_dup(pTHX_ DIR *dp)
7798 Perl_gp_dup(pTHX_ GP *gp)
7803 /* look for it in the table first */
7804 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7808 /* create anew and remember what it is */
7809 Newz(0, ret, 1, GP);
7810 ptr_table_store(PL_ptr_table, gp, ret);
7813 ret->gp_refcnt = 0; /* must be before any other dups! */
7814 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7815 ret->gp_io = io_dup_inc(gp->gp_io);
7816 ret->gp_form = cv_dup_inc(gp->gp_form);
7817 ret->gp_av = av_dup_inc(gp->gp_av);
7818 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7819 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7820 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7821 ret->gp_cvgen = gp->gp_cvgen;
7822 ret->gp_flags = gp->gp_flags;
7823 ret->gp_line = gp->gp_line;
7824 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7829 Perl_mg_dup(pTHX_ MAGIC *mg)
7831 MAGIC *mgprev = (MAGIC*)NULL;
7834 return (MAGIC*)NULL;
7835 /* look for it in the table first */
7836 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7840 for (; mg; mg = mg->mg_moremagic) {
7842 Newz(0, nmg, 1, MAGIC);
7844 mgprev->mg_moremagic = nmg;
7847 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7848 nmg->mg_private = mg->mg_private;
7849 nmg->mg_type = mg->mg_type;
7850 nmg->mg_flags = mg->mg_flags;
7851 if (mg->mg_type == PERL_MAGIC_qr) {
7852 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7855 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7856 ? sv_dup_inc(mg->mg_obj)
7857 : sv_dup(mg->mg_obj);
7859 nmg->mg_len = mg->mg_len;
7860 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7861 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
7862 if (mg->mg_len >= 0) {
7863 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7864 if (mg->mg_type == PERL_MAGIC_overload_table &&
7865 AMT_AMAGIC((AMT*)mg->mg_ptr))
7867 AMT *amtp = (AMT*)mg->mg_ptr;
7868 AMT *namtp = (AMT*)nmg->mg_ptr;
7870 for (i = 1; i < NofAMmeth; i++) {
7871 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7875 else if (mg->mg_len == HEf_SVKEY)
7876 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7884 Perl_ptr_table_new(pTHX)
7887 Newz(0, tbl, 1, PTR_TBL_t);
7890 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7895 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7897 PTR_TBL_ENT_t *tblent;
7898 UV hash = PTR2UV(sv);
7900 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7901 for (; tblent; tblent = tblent->next) {
7902 if (tblent->oldval == sv)
7903 return tblent->newval;
7909 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7911 PTR_TBL_ENT_t *tblent, **otblent;
7912 /* XXX this may be pessimal on platforms where pointers aren't good
7913 * hash values e.g. if they grow faster in the most significant
7915 UV hash = PTR2UV(oldv);
7919 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7920 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7921 if (tblent->oldval == oldv) {
7922 tblent->newval = newv;
7927 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7928 tblent->oldval = oldv;
7929 tblent->newval = newv;
7930 tblent->next = *otblent;
7933 if (i && tbl->tbl_items > tbl->tbl_max)
7934 ptr_table_split(tbl);
7938 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7940 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7941 UV oldsize = tbl->tbl_max + 1;
7942 UV newsize = oldsize * 2;
7945 Renew(ary, newsize, PTR_TBL_ENT_t*);
7946 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7947 tbl->tbl_max = --newsize;
7949 for (i=0; i < oldsize; i++, ary++) {
7950 PTR_TBL_ENT_t **curentp, **entp, *ent;
7953 curentp = ary + oldsize;
7954 for (entp = ary, ent = *ary; ent; ent = *entp) {
7955 if ((newsize & PTR2UV(ent->oldval)) != i) {
7957 ent->next = *curentp;
7968 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7970 register PTR_TBL_ENT_t **array;
7971 register PTR_TBL_ENT_t *entry;
7972 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7976 if (!tbl || !tbl->tbl_items) {
7980 array = tbl->tbl_ary;
7987 entry = entry->next;
7991 if (++riter > max) {
7994 entry = array[riter];
8002 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
8007 ptr_table_clear(tbl);
8008 Safefree(tbl->tbl_ary);
8017 S_gv_share(pTHX_ SV *sstr)
8020 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8022 if (GvIO(gv) || GvFORM(gv)) {
8023 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8025 else if (!GvCV(gv)) {
8029 /* CvPADLISTs cannot be shared */
8030 if (!CvXSUB(GvCV(gv))) {
8035 if (!GvSHARED(gv)) {
8037 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8038 HvNAME(GvSTASH(gv)), GvNAME(gv));
8044 * write attempts will die with
8045 * "Modification of a read-only value attempted"
8051 SvREADONLY_on(GvSV(gv));
8058 SvREADONLY_on(GvAV(gv));
8065 SvREADONLY_on(GvAV(gv));
8068 return sstr; /* he_dup() will SvREFCNT_inc() */
8072 Perl_sv_dup(pTHX_ SV *sstr)
8076 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8078 /* look for it in the table first */
8079 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8083 /* create anew and remember what it is */
8085 ptr_table_store(PL_ptr_table, sstr, dstr);
8088 SvFLAGS(dstr) = SvFLAGS(sstr);
8089 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8090 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8093 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8094 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8095 PL_watch_pvx, SvPVX(sstr));
8098 switch (SvTYPE(sstr)) {
8103 SvANY(dstr) = new_XIV();
8104 SvIVX(dstr) = SvIVX(sstr);
8107 SvANY(dstr) = new_XNV();
8108 SvNVX(dstr) = SvNVX(sstr);
8111 SvANY(dstr) = new_XRV();
8112 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
8113 ? sv_dup(SvRV(sstr))
8114 : sv_dup_inc(SvRV(sstr));
8117 SvANY(dstr) = new_XPV();
8118 SvCUR(dstr) = SvCUR(sstr);
8119 SvLEN(dstr) = SvLEN(sstr);
8121 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8122 ? sv_dup(SvRV(sstr))
8123 : sv_dup_inc(SvRV(sstr));
8124 else if (SvPVX(sstr) && SvLEN(sstr))
8125 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8127 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8130 SvANY(dstr) = new_XPVIV();
8131 SvCUR(dstr) = SvCUR(sstr);
8132 SvLEN(dstr) = SvLEN(sstr);
8133 SvIVX(dstr) = SvIVX(sstr);
8135 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8136 ? sv_dup(SvRV(sstr))
8137 : sv_dup_inc(SvRV(sstr));
8138 else if (SvPVX(sstr) && SvLEN(sstr))
8139 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8141 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8144 SvANY(dstr) = new_XPVNV();
8145 SvCUR(dstr) = SvCUR(sstr);
8146 SvLEN(dstr) = SvLEN(sstr);
8147 SvIVX(dstr) = SvIVX(sstr);
8148 SvNVX(dstr) = SvNVX(sstr);
8150 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8151 ? sv_dup(SvRV(sstr))
8152 : sv_dup_inc(SvRV(sstr));
8153 else if (SvPVX(sstr) && SvLEN(sstr))
8154 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8156 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8159 SvANY(dstr) = new_XPVMG();
8160 SvCUR(dstr) = SvCUR(sstr);
8161 SvLEN(dstr) = SvLEN(sstr);
8162 SvIVX(dstr) = SvIVX(sstr);
8163 SvNVX(dstr) = SvNVX(sstr);
8164 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8165 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8167 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8168 ? sv_dup(SvRV(sstr))
8169 : sv_dup_inc(SvRV(sstr));
8170 else if (SvPVX(sstr) && SvLEN(sstr))
8171 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8173 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8176 SvANY(dstr) = new_XPVBM();
8177 SvCUR(dstr) = SvCUR(sstr);
8178 SvLEN(dstr) = SvLEN(sstr);
8179 SvIVX(dstr) = SvIVX(sstr);
8180 SvNVX(dstr) = SvNVX(sstr);
8181 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8182 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8184 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8185 ? sv_dup(SvRV(sstr))
8186 : sv_dup_inc(SvRV(sstr));
8187 else if (SvPVX(sstr) && SvLEN(sstr))
8188 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8190 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8191 BmRARE(dstr) = BmRARE(sstr);
8192 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8193 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8196 SvANY(dstr) = new_XPVLV();
8197 SvCUR(dstr) = SvCUR(sstr);
8198 SvLEN(dstr) = SvLEN(sstr);
8199 SvIVX(dstr) = SvIVX(sstr);
8200 SvNVX(dstr) = SvNVX(sstr);
8201 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8202 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8204 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8205 ? sv_dup(SvRV(sstr))
8206 : sv_dup_inc(SvRV(sstr));
8207 else if (SvPVX(sstr) && SvLEN(sstr))
8208 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8210 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8211 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8212 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8213 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8214 LvTYPE(dstr) = LvTYPE(sstr);
8217 if (GvSHARED((GV*)sstr)) {
8219 if ((share = gv_share(sstr))) {
8223 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8224 HvNAME(GvSTASH(share)), GvNAME(share));
8229 SvANY(dstr) = new_XPVGV();
8230 SvCUR(dstr) = SvCUR(sstr);
8231 SvLEN(dstr) = SvLEN(sstr);
8232 SvIVX(dstr) = SvIVX(sstr);
8233 SvNVX(dstr) = SvNVX(sstr);
8234 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8235 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8237 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8238 ? sv_dup(SvRV(sstr))
8239 : sv_dup_inc(SvRV(sstr));
8240 else if (SvPVX(sstr) && SvLEN(sstr))
8241 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8243 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8244 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8245 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8246 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8247 GvFLAGS(dstr) = GvFLAGS(sstr);
8248 GvGP(dstr) = gp_dup(GvGP(sstr));
8249 (void)GpREFCNT_inc(GvGP(dstr));
8252 SvANY(dstr) = new_XPVIO();
8253 SvCUR(dstr) = SvCUR(sstr);
8254 SvLEN(dstr) = SvLEN(sstr);
8255 SvIVX(dstr) = SvIVX(sstr);
8256 SvNVX(dstr) = SvNVX(sstr);
8257 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8258 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8260 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8261 ? sv_dup(SvRV(sstr))
8262 : sv_dup_inc(SvRV(sstr));
8263 else if (SvPVX(sstr) && SvLEN(sstr))
8264 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8266 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8267 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8268 if (IoOFP(sstr) == IoIFP(sstr))
8269 IoOFP(dstr) = IoIFP(dstr);
8271 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8272 /* PL_rsfp_filters entries have fake IoDIRP() */
8273 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8274 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8276 IoDIRP(dstr) = IoDIRP(sstr);
8277 IoLINES(dstr) = IoLINES(sstr);
8278 IoPAGE(dstr) = IoPAGE(sstr);
8279 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8280 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8281 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8282 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8283 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8284 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8285 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8286 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8287 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8288 IoTYPE(dstr) = IoTYPE(sstr);
8289 IoFLAGS(dstr) = IoFLAGS(sstr);
8292 SvANY(dstr) = new_XPVAV();
8293 SvCUR(dstr) = SvCUR(sstr);
8294 SvLEN(dstr) = SvLEN(sstr);
8295 SvIVX(dstr) = SvIVX(sstr);
8296 SvNVX(dstr) = SvNVX(sstr);
8297 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8298 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8299 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8300 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8301 if (AvARRAY((AV*)sstr)) {
8302 SV **dst_ary, **src_ary;
8303 SSize_t items = AvFILLp((AV*)sstr) + 1;
8305 src_ary = AvARRAY((AV*)sstr);
8306 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8307 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8308 SvPVX(dstr) = (char*)dst_ary;
8309 AvALLOC((AV*)dstr) = dst_ary;
8310 if (AvREAL((AV*)sstr)) {
8312 *dst_ary++ = sv_dup_inc(*src_ary++);
8316 *dst_ary++ = sv_dup(*src_ary++);
8318 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8319 while (items-- > 0) {
8320 *dst_ary++ = &PL_sv_undef;
8324 SvPVX(dstr) = Nullch;
8325 AvALLOC((AV*)dstr) = (SV**)NULL;
8329 SvANY(dstr) = new_XPVHV();
8330 SvCUR(dstr) = SvCUR(sstr);
8331 SvLEN(dstr) = SvLEN(sstr);
8332 SvIVX(dstr) = SvIVX(sstr);
8333 SvNVX(dstr) = SvNVX(sstr);
8334 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8335 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8336 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8337 if (HvARRAY((HV*)sstr)) {
8339 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8340 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8341 Newz(0, dxhv->xhv_array,
8342 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8343 while (i <= sxhv->xhv_max) {
8344 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8345 !!HvSHAREKEYS(sstr));
8348 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8351 SvPVX(dstr) = Nullch;
8352 HvEITER((HV*)dstr) = (HE*)NULL;
8354 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8355 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8356 if(HvNAME((HV*)dstr))
8357 av_push(PL_clone_callbacks,dstr);
8360 SvANY(dstr) = new_XPVFM();
8361 FmLINES(dstr) = FmLINES(sstr);
8365 SvANY(dstr) = new_XPVCV();
8367 SvCUR(dstr) = SvCUR(sstr);
8368 SvLEN(dstr) = SvLEN(sstr);
8369 SvIVX(dstr) = SvIVX(sstr);
8370 SvNVX(dstr) = SvNVX(sstr);
8371 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8372 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8373 if (SvPVX(sstr) && SvLEN(sstr))
8374 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8376 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8377 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8378 CvSTART(dstr) = CvSTART(sstr);
8379 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8380 CvXSUB(dstr) = CvXSUB(sstr);
8381 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8382 CvGV(dstr) = gv_dup(CvGV(sstr));
8383 CvDEPTH(dstr) = CvDEPTH(sstr);
8384 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8385 /* XXX padlists are real, but pretend to be not */
8386 AvREAL_on(CvPADLIST(sstr));
8387 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8388 AvREAL_off(CvPADLIST(sstr));
8389 AvREAL_off(CvPADLIST(dstr));
8392 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8393 if (!CvANON(sstr) || CvCLONED(sstr))
8394 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8396 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8397 CvFLAGS(dstr) = CvFLAGS(sstr);
8400 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8404 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8411 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8416 return (PERL_CONTEXT*)NULL;
8418 /* look for it in the table first */
8419 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8423 /* create anew and remember what it is */
8424 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8425 ptr_table_store(PL_ptr_table, cxs, ncxs);
8428 PERL_CONTEXT *cx = &cxs[ix];
8429 PERL_CONTEXT *ncx = &ncxs[ix];
8430 ncx->cx_type = cx->cx_type;
8431 if (CxTYPE(cx) == CXt_SUBST) {
8432 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8435 ncx->blk_oldsp = cx->blk_oldsp;
8436 ncx->blk_oldcop = cx->blk_oldcop;
8437 ncx->blk_oldretsp = cx->blk_oldretsp;
8438 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8439 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8440 ncx->blk_oldpm = cx->blk_oldpm;
8441 ncx->blk_gimme = cx->blk_gimme;
8442 switch (CxTYPE(cx)) {
8444 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8445 ? cv_dup_inc(cx->blk_sub.cv)
8446 : cv_dup(cx->blk_sub.cv));
8447 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8448 ? av_dup_inc(cx->blk_sub.argarray)
8450 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8451 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8452 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8453 ncx->blk_sub.lval = cx->blk_sub.lval;
8456 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8457 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8458 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8459 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8460 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8463 ncx->blk_loop.label = cx->blk_loop.label;
8464 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8465 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8466 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8467 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8468 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8469 ? cx->blk_loop.iterdata
8470 : gv_dup((GV*)cx->blk_loop.iterdata));
8471 ncx->blk_loop.oldcurpad
8472 = (SV**)ptr_table_fetch(PL_ptr_table,
8473 cx->blk_loop.oldcurpad);
8474 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8475 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8476 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8477 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8478 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8481 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8482 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8483 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8484 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8497 Perl_si_dup(pTHX_ PERL_SI *si)
8502 return (PERL_SI*)NULL;
8504 /* look for it in the table first */
8505 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8509 /* create anew and remember what it is */
8510 Newz(56, nsi, 1, PERL_SI);
8511 ptr_table_store(PL_ptr_table, si, nsi);
8513 nsi->si_stack = av_dup_inc(si->si_stack);
8514 nsi->si_cxix = si->si_cxix;
8515 nsi->si_cxmax = si->si_cxmax;
8516 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8517 nsi->si_type = si->si_type;
8518 nsi->si_prev = si_dup(si->si_prev);
8519 nsi->si_next = si_dup(si->si_next);
8520 nsi->si_markoff = si->si_markoff;
8525 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8526 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8527 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8528 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8529 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8530 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8531 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8532 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8533 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8534 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8535 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8536 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8539 #define pv_dup_inc(p) SAVEPV(p)
8540 #define pv_dup(p) SAVEPV(p)
8541 #define svp_dup_inc(p,pp) any_dup(p,pp)
8544 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8551 /* look for it in the table first */
8552 ret = ptr_table_fetch(PL_ptr_table, v);
8556 /* see if it is part of the interpreter structure */
8557 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8558 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8566 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8568 ANY *ss = proto_perl->Tsavestack;
8569 I32 ix = proto_perl->Tsavestack_ix;
8570 I32 max = proto_perl->Tsavestack_max;
8583 void (*dptr) (void*);
8584 void (*dxptr) (pTHXo_ void*);
8587 Newz(54, nss, max, ANY);
8593 case SAVEt_ITEM: /* normal string */
8594 sv = (SV*)POPPTR(ss,ix);
8595 TOPPTR(nss,ix) = sv_dup_inc(sv);
8596 sv = (SV*)POPPTR(ss,ix);
8597 TOPPTR(nss,ix) = sv_dup_inc(sv);
8599 case SAVEt_SV: /* scalar reference */
8600 sv = (SV*)POPPTR(ss,ix);
8601 TOPPTR(nss,ix) = sv_dup_inc(sv);
8602 gv = (GV*)POPPTR(ss,ix);
8603 TOPPTR(nss,ix) = gv_dup_inc(gv);
8605 case SAVEt_GENERIC_PVREF: /* generic char* */
8606 c = (char*)POPPTR(ss,ix);
8607 TOPPTR(nss,ix) = pv_dup(c);
8608 ptr = POPPTR(ss,ix);
8609 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8611 case SAVEt_GENERIC_SVREF: /* generic sv */
8612 case SAVEt_SVREF: /* scalar reference */
8613 sv = (SV*)POPPTR(ss,ix);
8614 TOPPTR(nss,ix) = sv_dup_inc(sv);
8615 ptr = POPPTR(ss,ix);
8616 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8618 case SAVEt_AV: /* array reference */
8619 av = (AV*)POPPTR(ss,ix);
8620 TOPPTR(nss,ix) = av_dup_inc(av);
8621 gv = (GV*)POPPTR(ss,ix);
8622 TOPPTR(nss,ix) = gv_dup(gv);
8624 case SAVEt_HV: /* hash reference */
8625 hv = (HV*)POPPTR(ss,ix);
8626 TOPPTR(nss,ix) = hv_dup_inc(hv);
8627 gv = (GV*)POPPTR(ss,ix);
8628 TOPPTR(nss,ix) = gv_dup(gv);
8630 case SAVEt_INT: /* int reference */
8631 ptr = POPPTR(ss,ix);
8632 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8633 intval = (int)POPINT(ss,ix);
8634 TOPINT(nss,ix) = intval;
8636 case SAVEt_LONG: /* long reference */
8637 ptr = POPPTR(ss,ix);
8638 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8639 longval = (long)POPLONG(ss,ix);
8640 TOPLONG(nss,ix) = longval;
8642 case SAVEt_I32: /* I32 reference */
8643 case SAVEt_I16: /* I16 reference */
8644 case SAVEt_I8: /* I8 reference */
8645 ptr = POPPTR(ss,ix);
8646 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8650 case SAVEt_IV: /* IV reference */
8651 ptr = POPPTR(ss,ix);
8652 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8656 case SAVEt_SPTR: /* SV* reference */
8657 ptr = POPPTR(ss,ix);
8658 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8659 sv = (SV*)POPPTR(ss,ix);
8660 TOPPTR(nss,ix) = sv_dup(sv);
8662 case SAVEt_VPTR: /* random* reference */
8663 ptr = POPPTR(ss,ix);
8664 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8665 ptr = POPPTR(ss,ix);
8666 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8668 case SAVEt_PPTR: /* char* reference */
8669 ptr = POPPTR(ss,ix);
8670 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8671 c = (char*)POPPTR(ss,ix);
8672 TOPPTR(nss,ix) = pv_dup(c);
8674 case SAVEt_HPTR: /* HV* reference */
8675 ptr = POPPTR(ss,ix);
8676 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8677 hv = (HV*)POPPTR(ss,ix);
8678 TOPPTR(nss,ix) = hv_dup(hv);
8680 case SAVEt_APTR: /* AV* reference */
8681 ptr = POPPTR(ss,ix);
8682 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8683 av = (AV*)POPPTR(ss,ix);
8684 TOPPTR(nss,ix) = av_dup(av);
8687 gv = (GV*)POPPTR(ss,ix);
8688 TOPPTR(nss,ix) = gv_dup(gv);
8690 case SAVEt_GP: /* scalar reference */
8691 gp = (GP*)POPPTR(ss,ix);
8692 TOPPTR(nss,ix) = gp = gp_dup(gp);
8693 (void)GpREFCNT_inc(gp);
8694 gv = (GV*)POPPTR(ss,ix);
8695 TOPPTR(nss,ix) = gv_dup_inc(c);
8696 c = (char*)POPPTR(ss,ix);
8697 TOPPTR(nss,ix) = pv_dup(c);
8704 case SAVEt_MORTALIZESV:
8705 sv = (SV*)POPPTR(ss,ix);
8706 TOPPTR(nss,ix) = sv_dup_inc(sv);
8709 ptr = POPPTR(ss,ix);
8710 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8711 /* these are assumed to be refcounted properly */
8712 switch (((OP*)ptr)->op_type) {
8719 TOPPTR(nss,ix) = ptr;
8724 TOPPTR(nss,ix) = Nullop;
8729 TOPPTR(nss,ix) = Nullop;
8732 c = (char*)POPPTR(ss,ix);
8733 TOPPTR(nss,ix) = pv_dup_inc(c);
8736 longval = POPLONG(ss,ix);
8737 TOPLONG(nss,ix) = longval;
8740 hv = (HV*)POPPTR(ss,ix);
8741 TOPPTR(nss,ix) = hv_dup_inc(hv);
8742 c = (char*)POPPTR(ss,ix);
8743 TOPPTR(nss,ix) = pv_dup_inc(c);
8747 case SAVEt_DESTRUCTOR:
8748 ptr = POPPTR(ss,ix);
8749 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8750 dptr = POPDPTR(ss,ix);
8751 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8753 case SAVEt_DESTRUCTOR_X:
8754 ptr = POPPTR(ss,ix);
8755 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8756 dxptr = POPDXPTR(ss,ix);
8757 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8759 case SAVEt_REGCONTEXT:
8765 case SAVEt_STACK_POS: /* Position on Perl stack */
8769 case SAVEt_AELEM: /* array element */
8770 sv = (SV*)POPPTR(ss,ix);
8771 TOPPTR(nss,ix) = sv_dup_inc(sv);
8774 av = (AV*)POPPTR(ss,ix);
8775 TOPPTR(nss,ix) = av_dup_inc(av);
8777 case SAVEt_HELEM: /* hash element */
8778 sv = (SV*)POPPTR(ss,ix);
8779 TOPPTR(nss,ix) = sv_dup_inc(sv);
8780 sv = (SV*)POPPTR(ss,ix);
8781 TOPPTR(nss,ix) = sv_dup_inc(sv);
8782 hv = (HV*)POPPTR(ss,ix);
8783 TOPPTR(nss,ix) = hv_dup_inc(hv);
8786 ptr = POPPTR(ss,ix);
8787 TOPPTR(nss,ix) = ptr;
8794 av = (AV*)POPPTR(ss,ix);
8795 TOPPTR(nss,ix) = av_dup(av);
8798 longval = (long)POPLONG(ss,ix);
8799 TOPLONG(nss,ix) = longval;
8800 ptr = POPPTR(ss,ix);
8801 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8802 sv = (SV*)POPPTR(ss,ix);
8803 TOPPTR(nss,ix) = sv_dup(sv);
8806 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8818 perl_clone(PerlInterpreter *proto_perl, UV flags)
8821 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8824 #ifdef PERL_IMPLICIT_SYS
8825 return perl_clone_using(proto_perl, flags,
8827 proto_perl->IMemShared,
8828 proto_perl->IMemParse,
8838 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8839 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8840 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8841 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8842 struct IPerlDir* ipD, struct IPerlSock* ipS,
8843 struct IPerlProc* ipP)
8845 /* XXX many of the string copies here can be optimized if they're
8846 * constants; they need to be allocated as common memory and just
8847 * their pointers copied. */
8851 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8853 PERL_SET_THX(pPerl);
8854 # else /* !PERL_OBJECT */
8855 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8856 PERL_SET_THX(my_perl);
8859 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8865 # else /* !DEBUGGING */
8866 Zero(my_perl, 1, PerlInterpreter);
8867 # endif /* DEBUGGING */
8871 PL_MemShared = ipMS;
8879 # endif /* PERL_OBJECT */
8880 #else /* !PERL_IMPLICIT_SYS */
8882 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8883 PERL_SET_THX(my_perl);
8886 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8892 # else /* !DEBUGGING */
8893 Zero(my_perl, 1, PerlInterpreter);
8894 # endif /* DEBUGGING */
8895 #endif /* PERL_IMPLICIT_SYS */
8898 PL_xiv_arenaroot = NULL;
8900 PL_xnv_arenaroot = NULL;
8902 PL_xrv_arenaroot = NULL;
8904 PL_xpv_arenaroot = NULL;
8906 PL_xpviv_arenaroot = NULL;
8907 PL_xpviv_root = NULL;
8908 PL_xpvnv_arenaroot = NULL;
8909 PL_xpvnv_root = NULL;
8910 PL_xpvcv_arenaroot = NULL;
8911 PL_xpvcv_root = NULL;
8912 PL_xpvav_arenaroot = NULL;
8913 PL_xpvav_root = NULL;
8914 PL_xpvhv_arenaroot = NULL;
8915 PL_xpvhv_root = NULL;
8916 PL_xpvmg_arenaroot = NULL;
8917 PL_xpvmg_root = NULL;
8918 PL_xpvlv_arenaroot = NULL;
8919 PL_xpvlv_root = NULL;
8920 PL_xpvbm_arenaroot = NULL;
8921 PL_xpvbm_root = NULL;
8922 PL_he_arenaroot = NULL;
8924 PL_nice_chunk = NULL;
8925 PL_nice_chunk_size = 0;
8928 PL_sv_root = Nullsv;
8929 PL_sv_arenaroot = Nullsv;
8931 PL_debug = proto_perl->Idebug;
8933 /* create SV map for pointer relocation */
8934 PL_ptr_table = ptr_table_new();
8936 /* initialize these special pointers as early as possible */
8937 SvANY(&PL_sv_undef) = NULL;
8938 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8939 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8940 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8943 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8945 SvANY(&PL_sv_no) = new_XPVNV();
8947 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8948 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8949 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8950 SvCUR(&PL_sv_no) = 0;
8951 SvLEN(&PL_sv_no) = 1;
8952 SvNVX(&PL_sv_no) = 0;
8953 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8956 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8958 SvANY(&PL_sv_yes) = new_XPVNV();
8960 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8961 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8962 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8963 SvCUR(&PL_sv_yes) = 1;
8964 SvLEN(&PL_sv_yes) = 2;
8965 SvNVX(&PL_sv_yes) = 1;
8966 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8968 /* create shared string table */
8969 PL_strtab = newHV();
8970 HvSHAREKEYS_off(PL_strtab);
8971 hv_ksplit(PL_strtab, 512);
8972 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8974 PL_compiling = proto_perl->Icompiling;
8975 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8976 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8977 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8978 if (!specialWARN(PL_compiling.cop_warnings))
8979 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8980 if (!specialCopIO(PL_compiling.cop_io))
8981 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8982 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8984 /* pseudo environmental stuff */
8985 PL_origargc = proto_perl->Iorigargc;
8987 New(0, PL_origargv, i+1, char*);
8988 PL_origargv[i] = '\0';
8990 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8992 PL_clone_callbacks = newAV(); /* Setup array of objects to callbackon */
8993 PL_envgv = gv_dup(proto_perl->Ienvgv);
8994 PL_incgv = gv_dup(proto_perl->Iincgv);
8995 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8996 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8997 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8998 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
9001 PL_minus_c = proto_perl->Iminus_c;
9002 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
9003 PL_localpatches = proto_perl->Ilocalpatches;
9004 PL_splitstr = proto_perl->Isplitstr;
9005 PL_preprocess = proto_perl->Ipreprocess;
9006 PL_minus_n = proto_perl->Iminus_n;
9007 PL_minus_p = proto_perl->Iminus_p;
9008 PL_minus_l = proto_perl->Iminus_l;
9009 PL_minus_a = proto_perl->Iminus_a;
9010 PL_minus_F = proto_perl->Iminus_F;
9011 PL_doswitches = proto_perl->Idoswitches;
9012 PL_dowarn = proto_perl->Idowarn;
9013 PL_doextract = proto_perl->Idoextract;
9014 PL_sawampersand = proto_perl->Isawampersand;
9015 PL_unsafe = proto_perl->Iunsafe;
9016 PL_inplace = SAVEPV(proto_perl->Iinplace);
9017 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
9018 PL_perldb = proto_perl->Iperldb;
9019 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9021 /* magical thingies */
9022 /* XXX time(&PL_basetime) when asked for? */
9023 PL_basetime = proto_perl->Ibasetime;
9024 PL_formfeed = sv_dup(proto_perl->Iformfeed);
9026 PL_maxsysfd = proto_perl->Imaxsysfd;
9027 PL_multiline = proto_perl->Imultiline;
9028 PL_statusvalue = proto_perl->Istatusvalue;
9030 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9033 /* shortcuts to various I/O objects */
9034 PL_stdingv = gv_dup(proto_perl->Istdingv);
9035 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
9036 PL_defgv = gv_dup(proto_perl->Idefgv);
9037 PL_argvgv = gv_dup(proto_perl->Iargvgv);
9038 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
9039 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
9041 /* shortcuts to regexp stuff */
9042 PL_replgv = gv_dup(proto_perl->Ireplgv);
9044 /* shortcuts to misc objects */
9045 PL_errgv = gv_dup(proto_perl->Ierrgv);
9047 /* shortcuts to debugging objects */
9048 PL_DBgv = gv_dup(proto_perl->IDBgv);
9049 PL_DBline = gv_dup(proto_perl->IDBline);
9050 PL_DBsub = gv_dup(proto_perl->IDBsub);
9051 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
9052 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
9053 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
9054 PL_lineary = av_dup(proto_perl->Ilineary);
9055 PL_dbargs = av_dup(proto_perl->Idbargs);
9058 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
9059 PL_curstash = hv_dup(proto_perl->Tcurstash);
9060 PL_debstash = hv_dup(proto_perl->Idebstash);
9061 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
9062 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
9064 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
9065 PL_endav = av_dup_inc(proto_perl->Iendav);
9066 PL_checkav = av_dup_inc(proto_perl->Icheckav);
9067 PL_initav = av_dup_inc(proto_perl->Iinitav);
9069 PL_sub_generation = proto_perl->Isub_generation;
9071 /* funky return mechanisms */
9072 PL_forkprocess = proto_perl->Iforkprocess;
9074 /* subprocess state */
9075 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
9077 /* internal state */
9078 PL_tainting = proto_perl->Itainting;
9079 PL_maxo = proto_perl->Imaxo;
9080 if (proto_perl->Iop_mask)
9081 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9083 PL_op_mask = Nullch;
9085 /* current interpreter roots */
9086 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
9087 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9088 PL_main_start = proto_perl->Imain_start;
9089 PL_eval_root = proto_perl->Ieval_root;
9090 PL_eval_start = proto_perl->Ieval_start;
9092 /* runtime control stuff */
9093 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9094 PL_copline = proto_perl->Icopline;
9096 PL_filemode = proto_perl->Ifilemode;
9097 PL_lastfd = proto_perl->Ilastfd;
9098 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9101 PL_gensym = proto_perl->Igensym;
9102 PL_preambled = proto_perl->Ipreambled;
9103 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
9104 PL_laststatval = proto_perl->Ilaststatval;
9105 PL_laststype = proto_perl->Ilaststype;
9106 PL_mess_sv = Nullsv;
9108 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
9109 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9111 /* interpreter atexit processing */
9112 PL_exitlistlen = proto_perl->Iexitlistlen;
9113 if (PL_exitlistlen) {
9114 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9115 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9118 PL_exitlist = (PerlExitListEntry*)NULL;
9119 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
9121 PL_profiledata = NULL;
9122 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
9123 /* PL_rsfp_filters entries have fake IoDIRP() */
9124 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
9126 PL_compcv = cv_dup(proto_perl->Icompcv);
9127 PL_comppad = av_dup(proto_perl->Icomppad);
9128 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
9129 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9130 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9131 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9132 proto_perl->Tcurpad);
9134 #ifdef HAVE_INTERP_INTERN
9135 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9138 /* more statics moved here */
9139 PL_generation = proto_perl->Igeneration;
9140 PL_DBcv = cv_dup(proto_perl->IDBcv);
9142 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9143 PL_in_clean_all = proto_perl->Iin_clean_all;
9145 PL_uid = proto_perl->Iuid;
9146 PL_euid = proto_perl->Ieuid;
9147 PL_gid = proto_perl->Igid;
9148 PL_egid = proto_perl->Iegid;
9149 PL_nomemok = proto_perl->Inomemok;
9150 PL_an = proto_perl->Ian;
9151 PL_cop_seqmax = proto_perl->Icop_seqmax;
9152 PL_op_seqmax = proto_perl->Iop_seqmax;
9153 PL_evalseq = proto_perl->Ievalseq;
9154 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9155 PL_origalen = proto_perl->Iorigalen;
9156 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9157 PL_osname = SAVEPV(proto_perl->Iosname);
9158 PL_sh_path = SAVEPV(proto_perl->Ish_path);
9159 PL_sighandlerp = proto_perl->Isighandlerp;
9162 PL_runops = proto_perl->Irunops;
9164 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9167 PL_cshlen = proto_perl->Icshlen;
9168 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9171 PL_lex_state = proto_perl->Ilex_state;
9172 PL_lex_defer = proto_perl->Ilex_defer;
9173 PL_lex_expect = proto_perl->Ilex_expect;
9174 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9175 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9176 PL_lex_starts = proto_perl->Ilex_starts;
9177 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
9178 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
9179 PL_lex_op = proto_perl->Ilex_op;
9180 PL_lex_inpat = proto_perl->Ilex_inpat;
9181 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9182 PL_lex_brackets = proto_perl->Ilex_brackets;
9183 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9184 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9185 PL_lex_casemods = proto_perl->Ilex_casemods;
9186 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9187 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9189 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9190 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9191 PL_nexttoke = proto_perl->Inexttoke;
9193 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9194 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9195 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9196 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9197 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9198 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9199 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9200 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9201 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9202 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9203 PL_pending_ident = proto_perl->Ipending_ident;
9204 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9206 PL_expect = proto_perl->Iexpect;
9208 PL_multi_start = proto_perl->Imulti_start;
9209 PL_multi_end = proto_perl->Imulti_end;
9210 PL_multi_open = proto_perl->Imulti_open;
9211 PL_multi_close = proto_perl->Imulti_close;
9213 PL_error_count = proto_perl->Ierror_count;
9214 PL_subline = proto_perl->Isubline;
9215 PL_subname = sv_dup_inc(proto_perl->Isubname);
9217 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9218 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9219 PL_padix = proto_perl->Ipadix;
9220 PL_padix_floor = proto_perl->Ipadix_floor;
9221 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9223 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9224 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9225 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9226 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9227 PL_last_lop_op = proto_perl->Ilast_lop_op;
9228 PL_in_my = proto_perl->Iin_my;
9229 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9231 PL_cryptseen = proto_perl->Icryptseen;
9234 PL_hints = proto_perl->Ihints;
9236 PL_amagic_generation = proto_perl->Iamagic_generation;
9238 #ifdef USE_LOCALE_COLLATE
9239 PL_collation_ix = proto_perl->Icollation_ix;
9240 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9241 PL_collation_standard = proto_perl->Icollation_standard;
9242 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9243 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9244 #endif /* USE_LOCALE_COLLATE */
9246 #ifdef USE_LOCALE_NUMERIC
9247 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9248 PL_numeric_standard = proto_perl->Inumeric_standard;
9249 PL_numeric_local = proto_perl->Inumeric_local;
9250 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
9251 #endif /* !USE_LOCALE_NUMERIC */
9253 /* utf8 character classes */
9254 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9255 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9256 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9257 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9258 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9259 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9260 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9261 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9262 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9263 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9264 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9265 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9266 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9267 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9268 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9269 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9270 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9273 PL_last_swash_hv = Nullhv; /* reinits on demand */
9274 PL_last_swash_klen = 0;
9275 PL_last_swash_key[0]= '\0';
9276 PL_last_swash_tmps = (U8*)NULL;
9277 PL_last_swash_slen = 0;
9279 /* perly.c globals */
9280 PL_yydebug = proto_perl->Iyydebug;
9281 PL_yynerrs = proto_perl->Iyynerrs;
9282 PL_yyerrflag = proto_perl->Iyyerrflag;
9283 PL_yychar = proto_perl->Iyychar;
9284 PL_yyval = proto_perl->Iyyval;
9285 PL_yylval = proto_perl->Iyylval;
9287 PL_glob_index = proto_perl->Iglob_index;
9288 PL_srand_called = proto_perl->Isrand_called;
9289 PL_uudmap['M'] = 0; /* reinits on demand */
9290 PL_bitcount = Nullch; /* reinits on demand */
9292 if (proto_perl->Ipsig_pend) {
9293 Newz(0, PL_psig_pend, SIG_SIZE, int);
9296 PL_psig_pend = (int*)NULL;
9299 if (proto_perl->Ipsig_ptr) {
9300 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9301 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9302 for (i = 1; i < SIG_SIZE; i++) {
9303 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9304 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9308 PL_psig_ptr = (SV**)NULL;
9309 PL_psig_name = (SV**)NULL;
9312 /* thrdvar.h stuff */
9314 if (flags & CLONEf_COPY_STACKS) {
9315 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9316 PL_tmps_ix = proto_perl->Ttmps_ix;
9317 PL_tmps_max = proto_perl->Ttmps_max;
9318 PL_tmps_floor = proto_perl->Ttmps_floor;
9319 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9321 while (i <= PL_tmps_ix) {
9322 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9326 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9327 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9328 Newz(54, PL_markstack, i, I32);
9329 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9330 - proto_perl->Tmarkstack);
9331 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9332 - proto_perl->Tmarkstack);
9333 Copy(proto_perl->Tmarkstack, PL_markstack,
9334 PL_markstack_ptr - PL_markstack + 1, I32);
9336 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9337 * NOTE: unlike the others! */
9338 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9339 PL_scopestack_max = proto_perl->Tscopestack_max;
9340 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9341 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9343 /* next push_return() sets PL_retstack[PL_retstack_ix]
9344 * NOTE: unlike the others! */
9345 PL_retstack_ix = proto_perl->Tretstack_ix;
9346 PL_retstack_max = proto_perl->Tretstack_max;
9347 Newz(54, PL_retstack, PL_retstack_max, OP*);
9348 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9350 /* NOTE: si_dup() looks at PL_markstack */
9351 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9353 /* PL_curstack = PL_curstackinfo->si_stack; */
9354 PL_curstack = av_dup(proto_perl->Tcurstack);
9355 PL_mainstack = av_dup(proto_perl->Tmainstack);
9357 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9358 PL_stack_base = AvARRAY(PL_curstack);
9359 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9360 - proto_perl->Tstack_base);
9361 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9363 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9364 * NOTE: unlike the others! */
9365 PL_savestack_ix = proto_perl->Tsavestack_ix;
9366 PL_savestack_max = proto_perl->Tsavestack_max;
9367 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9368 PL_savestack = ss_dup(proto_perl);
9372 ENTER; /* perl_destruct() wants to LEAVE; */
9375 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9376 PL_top_env = &PL_start_env;
9378 PL_op = proto_perl->Top;
9381 PL_Xpv = (XPV*)NULL;
9382 PL_na = proto_perl->Tna;
9384 PL_statbuf = proto_perl->Tstatbuf;
9385 PL_statcache = proto_perl->Tstatcache;
9386 PL_statgv = gv_dup(proto_perl->Tstatgv);
9387 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9389 PL_timesbuf = proto_perl->Ttimesbuf;
9392 PL_tainted = proto_perl->Ttainted;
9393 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9394 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9395 PL_rs = sv_dup_inc(proto_perl->Trs);
9396 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9397 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9398 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9399 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9400 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9401 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9402 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9404 PL_restartop = proto_perl->Trestartop;
9405 PL_in_eval = proto_perl->Tin_eval;
9406 PL_delaymagic = proto_perl->Tdelaymagic;
9407 PL_dirty = proto_perl->Tdirty;
9408 PL_localizing = proto_perl->Tlocalizing;
9410 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9411 PL_protect = proto_perl->Tprotect;
9413 PL_errors = sv_dup_inc(proto_perl->Terrors);
9414 PL_av_fetch_sv = Nullsv;
9415 PL_hv_fetch_sv = Nullsv;
9416 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9417 PL_modcount = proto_perl->Tmodcount;
9418 PL_lastgotoprobe = Nullop;
9419 PL_dumpindent = proto_perl->Tdumpindent;
9421 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9422 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9423 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9424 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9425 PL_sortcxix = proto_perl->Tsortcxix;
9426 PL_efloatbuf = Nullch; /* reinits on demand */
9427 PL_efloatsize = 0; /* reinits on demand */
9431 PL_screamfirst = NULL;
9432 PL_screamnext = NULL;
9433 PL_maxscream = -1; /* reinits on demand */
9434 PL_lastscream = Nullsv;
9436 PL_watchaddr = NULL;
9437 PL_watchok = Nullch;
9439 PL_regdummy = proto_perl->Tregdummy;
9440 PL_regcomp_parse = Nullch;
9441 PL_regxend = Nullch;
9442 PL_regcode = (regnode*)NULL;
9445 PL_regprecomp = Nullch;
9450 PL_seen_zerolen = 0;
9452 PL_regcomp_rx = (regexp*)NULL;
9454 PL_colorset = 0; /* reinits PL_colors[] */
9455 /*PL_colors[6] = {0,0,0,0,0,0};*/
9456 PL_reg_whilem_seen = 0;
9457 PL_reginput = Nullch;
9460 PL_regstartp = (I32*)NULL;
9461 PL_regendp = (I32*)NULL;
9462 PL_reglastparen = (U32*)NULL;
9463 PL_regtill = Nullch;
9464 PL_reg_start_tmp = (char**)NULL;
9465 PL_reg_start_tmpl = 0;
9466 PL_regdata = (struct reg_data*)NULL;
9469 PL_reg_eval_set = 0;
9471 PL_regprogram = (regnode*)NULL;
9473 PL_regcc = (CURCUR*)NULL;
9474 PL_reg_call_cc = (struct re_cc_state*)NULL;
9475 PL_reg_re = (regexp*)NULL;
9476 PL_reg_ganch = Nullch;
9478 PL_reg_magic = (MAGIC*)NULL;
9480 PL_reg_oldcurpm = (PMOP*)NULL;
9481 PL_reg_curpm = (PMOP*)NULL;
9482 PL_reg_oldsaved = Nullch;
9483 PL_reg_oldsavedlen = 0;
9485 PL_reg_leftiter = 0;
9486 PL_reg_poscache = Nullch;
9487 PL_reg_poscache_size= 0;
9489 /* RE engine - function pointers */
9490 PL_regcompp = proto_perl->Tregcompp;
9491 PL_regexecp = proto_perl->Tregexecp;
9492 PL_regint_start = proto_perl->Tregint_start;
9493 PL_regint_string = proto_perl->Tregint_string;
9494 PL_regfree = proto_perl->Tregfree;
9496 PL_reginterp_cnt = 0;
9497 PL_reg_starttry = 0;
9499 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9500 ptr_table_free(PL_ptr_table);
9501 PL_ptr_table = NULL;
9504 while(av_len(PL_clone_callbacks) != -1) {
9505 HV* stash = (HV*) av_shift(PL_clone_callbacks);
9506 CV* cloner = (CV*) gv_fetchmethod_autoload(stash,"CLONE",0);
9509 cloner = GvCV(cloner);
9513 XPUSHs(newSVpv(HvNAME(stash),0));
9515 call_sv((SV*)cloner, G_DISCARD);
9523 return (PerlInterpreter*)pPerl;
9529 #else /* !USE_ITHREADS */
9535 #endif /* USE_ITHREADS */
9538 do_report_used(pTHXo_ SV *sv)
9540 if (SvTYPE(sv) != SVTYPEMASK) {
9541 PerlIO_printf(Perl_debug_log, "****\n");
9547 do_clean_objs(pTHXo_ SV *sv)
9551 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9552 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
9553 if (SvWEAKREF(sv)) {
9564 /* XXX Might want to check arrays, etc. */
9567 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9569 do_clean_named_objs(pTHXo_ SV *sv)
9571 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9572 if ( SvOBJECT(GvSV(sv)) ||
9573 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9574 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9575 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9576 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9578 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
9586 do_clean_all(pTHXo_ SV *sv)
9588 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
9589 SvFLAGS(sv) |= SVf_BREAK;