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 /* the number can be converted to integer with atol() or atoll() although */
1490 #define IS_NUMBER_TO_INT_BY_ATOL 0x01 /* integer (may have decimals) */
1491 #define IS_NUMBER_TO_INT_BY_STRTOL 0x02 /* it may exceed IV_MAX */
1492 #define IS_NUMBER_TO_INT_BY_ATOF 0x04 /* seen something like 123e4 */
1493 #define IS_NUMBER_LONGER_THAN_IV_MAX 0x08 /* more digits than IV_MAX */
1494 #define IS_NUMBER_AS_LONG_AS_IV_MAX 0x10 /* may(be not) larger than IV_MAX */
1495 #define IS_NUMBER_NOT_INT 0x20 /* seen a decimal point or e */
1496 #define IS_NUMBER_NEG 0x40 /* seen a leading - */
1497 #define IS_NUMBER_INFINITY 0x80 /* /^\s*-?Infinity\s*$/i */
1499 /* Actually, ISO C leaves conversion of UV to IV undefined, but
1500 until proven guilty, assume that things are not that bad... */
1502 /* As 64 bit platforms often have an NV that doesn't preserve all bits of
1503 an IV (an assumption perl has been based on to date) it becomes necessary
1504 to remove the assumption that the NV always carries enough precision to
1505 recreate the IV whenever needed, and that the NV is the canonical form.
1506 Instead, IV/UV and NV need to be given equal rights. So as to not lose
1507 precision as an side effect of conversion (which would lead to insanity
1508 and the dragon(s) in t/op/numconvert.t getting very angry) the intent is
1509 1) to distinguish between IV/UV/NV slots that have cached a valid
1510 conversion where precision was lost and IV/UV/NV slots that have a
1511 valid conversion which has lost no precision
1512 2) to ensure that if a numeric conversion to one form is request that
1513 would lose precision, the precise conversion (or differently
1514 imprecise conversion) is also performed and cached, to prevent
1515 requests for different numeric formats on the same SV causing
1516 lossy conversion chains. (lossless conversion chains are perfectly
1521 SvIOKp is true if the IV slot contains a valid value
1522 SvIOK is true only if the IV value is accurate (UV if SvIOK_UV true)
1523 SvNOKp is true if the NV slot contains a valid value
1524 SvNOK is true only if the NV value is accurate
1527 while converting from PV to NV check to see if converting that NV to an
1528 IV(or UV) would lose accuracy over a direct conversion from PV to
1529 IV(or UV). If it would, cache both conversions, return NV, but mark
1530 SV as IOK NOKp (ie not NOK).
1532 while converting from PV to IV check to see if converting that IV to an
1533 NV would lose accuracy over a direct conversion from PV to NV. If it
1534 would, cache both conversions, flag similarly.
1536 Before, the SV value "3.2" could become NV=3.2 IV=3 NOK, IOK quite
1537 correctly because if IV & NV were set NV *always* overruled.
1538 Now, "3.2" will become NV=3.2 IV=3 NOK, IOKp, because the flags meaning
1539 changes - now IV and NV together means that the two are interchangeable
1540 SvIVX == (IV) SvNVX && SvNVX == (NV) SvIVX;
1542 The benefit of this is operations such as pp_add know that if SvIOK is
1543 true for both left and right operands, then integer addition can be
1544 used instead of floating point. (for cases where the result won't
1545 overflow) Before, floating point was always used, which could lead to
1546 loss of precision compared with integer addition.
1548 * making IV and NV equal status should make maths accurate on 64 bit
1550 * may speed up maths somewhat if pp_add and friends start to use
1551 integers when possible instead of fp. (hopefully the overhead in
1552 looking for SvIOK and checking for overflow will not outweigh the
1553 fp to integer speedup)
1554 * will slow down integer operations (callers of SvIV) on "inaccurate"
1555 values, as the change from SvIOK to SvIOKp will cause a call into
1556 sv_2iv each time rather than a macro access direct to the IV slot
1557 * should speed up number->string conversion on integers as IV is
1558 favoured when IV and NV equally accurate
1560 ####################################################################
1561 You had better be using SvIOK_notUV if you want an IV for arithmetic
1562 SvIOK is true if (IV or UV), so you might be getting (IV)SvUV
1563 SvUOK is true iff UV.
1564 ####################################################################
1566 Your mileage will vary depending your CPUs relative fp to integer
1570 #ifndef NV_PRESERVES_UV
1571 #define IS_NUMBER_UNDERFLOW_IV 1
1572 #define IS_NUMBER_UNDERFLOW_UV 2
1573 #define IS_NUMBER_IV_AND_UV 2
1574 #define IS_NUMBER_OVERFLOW_IV 4
1575 #define IS_NUMBER_OVERFLOW_UV 5
1576 /* Hopefully your optimiser will consider inlining these two functions. */
1578 S_sv_2inuv_non_preserve (pTHX_ register SV *sv, I32 numtype) {
1579 NV nv = SvNVX(sv); /* Code simpler and had compiler problems if */
1580 UV nv_as_uv = U_V(nv); /* these are not in simple variables. */
1581 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2inuv_non '%s', IV=0x%"UVxf" NV=%g inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, (UV)numtype));
1582 if (nv_as_uv <= (UV)IV_MAX) {
1583 (void)SvIOKp_on(sv);
1584 (void)SvNOKp_on(sv);
1585 /* Within suitable range to fit in an IV, atol won't overflow */
1586 /* XXX quite sure? Is that your final answer? not really, I'm
1587 trusting that nv_as_uv to round down if NV is (IV_MAX + 1) */
1588 SvIVX(sv) = (IV)Atol(SvPVX(sv));
1589 if (numtype & IS_NUMBER_NOT_INT) {
1590 /* I believe that even if the original PV had decimals, they
1591 are lost beyond the limit of the FP precision.
1592 However, neither is canonical, so both only get p flags.
1594 /* Both already have p flags, so do nothing */
1595 } else if (SvIVX(sv) == I_V(nv)) {
1600 /* It had no "." so it must be integer. assert (get in here from
1601 sv_2iv and sv_2uv only for ndef HAS_STRTOL and
1602 IS_NUMBER_AS_LONG_AS_IV_MAX) or my logic is faulty and all
1603 conversion routines need audit. */
1605 return nv < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1607 /* between IV_MAX and NV(UV_MAX). Could be slightly> UV_MAX */
1608 (void)SvIOKp_on(sv);
1609 (void)SvNOKp_on(sv);
1612 int save_errno = errno;
1614 SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10);
1616 if (numtype & IS_NUMBER_NOT_INT) {
1617 /* UV and NV both imprecise. */
1619 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1628 return IS_NUMBER_OVERFLOW_IV;
1632 /* Must have just overflowed UV, but not enough that an NV could spot
1634 return IS_NUMBER_OVERFLOW_UV;
1637 /* We've just lost integer precision, nothing we could do. */
1638 SvUVX(sv) = nv_as_uv;
1639 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2niuv_non UV? '%s', UV=0x%"UVxf" NV=%g U_V(NV)=0x%"UVxf" inttype=%"UVXf"\n", SvPVX(sv), SvIVX(sv), nv, nv_as_uv, (UV)numtype));
1640 /* UV and NV slots equally valid only if we have casting symmetry. */
1641 if (numtype & IS_NUMBER_NOT_INT) {
1643 } else if (SvUVX(sv) == nv_as_uv && SvUVX(sv) != UV_MAX) {
1644 /* UV_MAX can cast up to NV (UV_MAX+1), that NV casts down to UV_MAX
1645 UV_MAX ought to be 0xFF...FFF which won't preserve (We only
1646 get to this point if NVs don't preserve UVs) */
1651 /* As above, I believe UV at least as good as NV */
1654 #endif /* HAS_STRTOUL */
1655 return IS_NUMBER_OVERFLOW_IV;
1658 /* For sv_2nv these three cases are "SvNOK and don't bother casting" */
1660 S_sv_2iuv_non_preserve (pTHX_ register SV *sv, I32 numtype)
1662 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));
1663 if (SvNVX(sv) < (NV)IV_MIN) {
1664 (void)SvIOKp_on(sv);
1667 return IS_NUMBER_UNDERFLOW_IV;
1669 if (SvNVX(sv) > (NV)UV_MAX) {
1670 (void)SvIOKp_on(sv);
1674 return IS_NUMBER_OVERFLOW_UV;
1676 if (!(numtype & (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
1677 (void)SvIOKp_on(sv);
1679 /* Can't use strtol etc to convert this string */
1680 if (SvNVX(sv) <= (UV)IV_MAX) {
1681 SvIVX(sv) = I_V(SvNVX(sv));
1682 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1683 SvIOK_on(sv); /* Integer is precise. NOK, IOK */
1685 /* Integer is imprecise. NOK, IOKp */
1687 return SvNVX(sv) < 0 ? IS_NUMBER_UNDERFLOW_UV : IS_NUMBER_IV_AND_UV;
1690 SvUVX(sv) = U_V(SvNVX(sv));
1691 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1692 if (SvUVX(sv) == UV_MAX) {
1693 /* As we know that NVs don't preserve UVs, UV_MAX cannot
1694 possibly be preserved by NV. Hence, it must be overflow.
1696 return IS_NUMBER_OVERFLOW_UV;
1698 SvIOK_on(sv); /* Integer is precise. NOK, UOK */
1700 /* Integer is imprecise. NOK, IOKp */
1702 return IS_NUMBER_OVERFLOW_IV;
1704 return S_sv_2inuv_non_preserve(aTHX_ sv, numtype);
1706 #endif /* NV_PRESERVES_UV*/
1709 Perl_sv_2iv(pTHX_ register SV *sv)
1713 if (SvGMAGICAL(sv)) {
1718 return I_V(SvNVX(sv));
1720 if (SvPOKp(sv) && SvLEN(sv))
1723 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1724 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1730 if (SvTHINKFIRST(sv)) {
1733 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1734 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1735 return SvIV(tmpstr);
1736 return PTR2IV(SvRV(sv));
1738 if (SvREADONLY(sv) && SvFAKE(sv)) {
1739 sv_force_normal(sv);
1741 if (SvREADONLY(sv) && !SvOK(sv)) {
1742 if (ckWARN(WARN_UNINITIALIZED))
1749 return (IV)(SvUVX(sv));
1756 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
1757 * without also getting a cached IV/UV from it at the same time
1758 * (ie PV->NV conversion should detect loss of accuracy and cache
1759 * IV or UV at same time to avoid this. NWC */
1761 if (SvTYPE(sv) == SVt_NV)
1762 sv_upgrade(sv, SVt_PVNV);
1764 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
1765 /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost
1766 certainly cast into the IV range at IV_MAX, whereas the correct
1767 answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary
1769 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1770 SvIVX(sv) = I_V(SvNVX(sv));
1771 if (SvNVX(sv) == (NV) SvIVX(sv)
1772 #ifndef NV_PRESERVES_UV
1773 && (((UV)1 << NV_PRESERVES_UV_BITS) >
1774 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
1775 /* Don't flag it as "accurately an integer" if the number
1776 came from a (by definition imprecise) NV operation, and
1777 we're outside the range of NV integer precision */
1780 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
1781 DEBUG_c(PerlIO_printf(Perl_debug_log,
1782 "0x%"UVxf" iv(%g => %"IVdf") (precise)\n",
1788 /* IV not precise. No need to convert from PV, as NV
1789 conversion would already have cached IV if it detected
1790 that PV->IV would be better than PV->NV->IV
1791 flags already correct - don't set public IOK. */
1792 DEBUG_c(PerlIO_printf(Perl_debug_log,
1793 "0x%"UVxf" iv(%g => %"IVdf") (imprecise)\n",
1798 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
1799 but the cast (NV)IV_MIN rounds to a the value less (more
1800 negative) than IV_MIN which happens to be equal to SvNVX ??
1801 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
1802 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
1803 (NV)UVX == NVX are both true, but the values differ. :-(
1804 Hopefully for 2s complement IV_MIN is something like
1805 0x8000000000000000 which will be exact. NWC */
1808 SvUVX(sv) = U_V(SvNVX(sv));
1810 (SvNVX(sv) == (NV) SvUVX(sv))
1811 #ifndef NV_PRESERVES_UV
1812 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
1813 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
1814 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
1815 /* Don't flag it as "accurately an integer" if the number
1816 came from a (by definition imprecise) NV operation, and
1817 we're outside the range of NV integer precision */
1823 DEBUG_c(PerlIO_printf(Perl_debug_log,
1824 "0x%"UVxf" 2iv(%"UVuf" => %"IVdf") (as unsigned)\n",
1828 return (IV)SvUVX(sv);
1831 else if (SvPOKp(sv) && SvLEN(sv)) {
1832 I32 numtype = looks_like_number(sv);
1834 /* We want to avoid a possible problem when we cache an IV which
1835 may be later translated to an NV, and the resulting NV is not
1836 the translation of the initial data.
1838 This means that if we cache such an IV, we need to cache the
1839 NV as well. Moreover, we trade speed for space, and do not
1840 cache the NV if we are sure it's not needed.
1843 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
1844 /* The NV may be reconstructed from IV - safe to cache IV,
1845 which may be calculated by atol(). */
1846 if (SvTYPE(sv) < SVt_PVIV)
1847 sv_upgrade(sv, SVt_PVIV);
1849 SvIVX(sv) = Atol(SvPVX(sv));
1853 int save_errno = errno;
1854 /* Is it an integer that we could convert with strtol?
1855 So try it, and if it doesn't set errno then it's pukka.
1856 This should be faster than going atof and then thinking. */
1857 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
1858 == IS_NUMBER_TO_INT_BY_STRTOL)
1859 /* && is a sequence point. Without it not sure if I'm trying
1860 to do too much between sequence points and hence going
1862 && ((errno = 0), 1) /* , 1 so always true */
1863 && ((i = Strtol(SvPVX(sv), Null(char**), 10)), 1)
1865 if (SvTYPE(sv) < SVt_PVIV)
1866 sv_upgrade(sv, SVt_PVIV);
1875 /* Hopefully trace flow will optimise this away where possible
1879 /* It wasn't an integer, or it overflowed, or we don't have
1880 strtol. Do things the slow way - check if it's a UV etc. */
1881 d = Atof(SvPVX(sv));
1883 if (SvTYPE(sv) < SVt_PVNV)
1884 sv_upgrade(sv, SVt_PVNV);
1887 if (! numtype && ckWARN(WARN_NUMERIC))
1890 #if defined(USE_LONG_DOUBLE)
1891 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%" PERL_PRIgldbl ")\n",
1892 PTR2UV(sv), SvNVX(sv)));
1894 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%g)\n",
1895 PTR2UV(sv), SvNVX(sv)));
1899 #ifdef NV_PRESERVES_UV
1900 (void)SvIOKp_on(sv);
1902 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
1903 SvIVX(sv) = I_V(SvNVX(sv));
1904 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
1907 /* Integer is imprecise. NOK, IOKp */
1909 /* UV will not work better than IV */
1911 if (SvNVX(sv) > (NV)UV_MAX) {
1913 /* Integer is inaccurate. NOK, IOKp, is UV */
1917 SvUVX(sv) = U_V(SvNVX(sv));
1918 /* 0xFFFFFFFFFFFFFFFF not an issue in here */
1919 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
1923 /* Integer is imprecise. NOK, IOKp, is UV */
1929 #else /* NV_PRESERVES_UV */
1930 if (((UV)1 << NV_PRESERVES_UV_BITS) >
1931 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
1932 /* Small enough to preserve all bits. */
1933 (void)SvIOKp_on(sv);
1935 SvIVX(sv) = I_V(SvNVX(sv));
1936 if ((NV)(SvIVX(sv)) == SvNVX(sv))
1938 /* Assumption: first non-preserved integer is < IV_MAX,
1939 this NV is in the preserved range, therefore: */
1940 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
1942 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);
1944 } else if (sv_2iuv_non_preserve (sv, numtype)
1945 >= IS_NUMBER_OVERFLOW_IV)
1947 #endif /* NV_PRESERVES_UV */
1951 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
1953 if (SvTYPE(sv) < SVt_IV)
1954 /* Typically the caller expects that sv_any is not NULL now. */
1955 sv_upgrade(sv, SVt_IV);
1958 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2iv(%"IVdf")\n",
1959 PTR2UV(sv),SvIVX(sv)));
1960 return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv);
1964 Perl_sv_2uv(pTHX_ register SV *sv)
1968 if (SvGMAGICAL(sv)) {
1973 return U_V(SvNVX(sv));
1974 if (SvPOKp(sv) && SvLEN(sv))
1977 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
1978 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
1984 if (SvTHINKFIRST(sv)) {
1987 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
1988 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
1989 return SvUV(tmpstr);
1990 return PTR2UV(SvRV(sv));
1992 if (SvREADONLY(sv) && SvFAKE(sv)) {
1993 sv_force_normal(sv);
1995 if (SvREADONLY(sv) && !SvOK(sv)) {
1996 if (ckWARN(WARN_UNINITIALIZED))
2006 return (UV)SvIVX(sv);
2010 /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv
2011 * without also getting a cached IV/UV from it at the same time
2012 * (ie PV->NV conversion should detect loss of accuracy and cache
2013 * IV or UV at same time to avoid this. */
2014 /* IV-over-UV optimisation - choose to cache IV if possible */
2016 if (SvTYPE(sv) == SVt_NV)
2017 sv_upgrade(sv, SVt_PVNV);
2019 (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */
2020 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2021 SvIVX(sv) = I_V(SvNVX(sv));
2022 if (SvNVX(sv) == (NV) SvIVX(sv)
2023 #ifndef NV_PRESERVES_UV
2024 && (((UV)1 << NV_PRESERVES_UV_BITS) >
2025 (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv)))
2026 /* Don't flag it as "accurately an integer" if the number
2027 came from a (by definition imprecise) NV operation, and
2028 we're outside the range of NV integer precision */
2031 SvIOK_on(sv); /* Can this go wrong with rounding? NWC */
2032 DEBUG_c(PerlIO_printf(Perl_debug_log,
2033 "0x%"UVxf" uv(%g => %"IVdf") (precise)\n",
2039 /* IV not precise. No need to convert from PV, as NV
2040 conversion would already have cached IV if it detected
2041 that PV->IV would be better than PV->NV->IV
2042 flags already correct - don't set public IOK. */
2043 DEBUG_c(PerlIO_printf(Perl_debug_log,
2044 "0x%"UVxf" uv(%g => %"IVdf") (imprecise)\n",
2049 /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN,
2050 but the cast (NV)IV_MIN rounds to a the value less (more
2051 negative) than IV_MIN which happens to be equal to SvNVX ??
2052 Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and
2053 NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and
2054 (NV)UVX == NVX are both true, but the values differ. :-(
2055 Hopefully for 2s complement IV_MIN is something like
2056 0x8000000000000000 which will be exact. NWC */
2059 SvUVX(sv) = U_V(SvNVX(sv));
2061 (SvNVX(sv) == (NV) SvUVX(sv))
2062 #ifndef NV_PRESERVES_UV
2063 /* Make sure it's not 0xFFFFFFFFFFFFFFFF */
2064 /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */
2065 && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv))
2066 /* Don't flag it as "accurately an integer" if the number
2067 came from a (by definition imprecise) NV operation, and
2068 we're outside the range of NV integer precision */
2073 DEBUG_c(PerlIO_printf(Perl_debug_log,
2074 "0x%"UVxf" 2uv(%"UVuf" => %"IVdf") (as unsigned)\n",
2080 else if (SvPOKp(sv) && SvLEN(sv)) {
2081 I32 numtype = looks_like_number(sv);
2083 /* We want to avoid a possible problem when we cache a UV which
2084 may be later translated to an NV, and the resulting NV is not
2085 the translation of the initial data.
2087 This means that if we cache such a UV, we need to cache the
2088 NV as well. Moreover, we trade speed for space, and do not
2089 cache the NV if not needed.
2092 if ((numtype & ~IS_NUMBER_NEG) == IS_NUMBER_TO_INT_BY_ATOL) {
2093 /* The NV may be reconstructed from IV - safe to cache IV,
2094 which may be calculated by atol(). */
2095 if (SvTYPE(sv) < SVt_PVIV)
2096 sv_upgrade(sv, SVt_PVIV);
2098 SvIVX(sv) = Atol(SvPVX(sv));
2102 char *num_begin = SvPVX(sv);
2103 int save_errno = errno;
2105 /* seems that strtoul taking numbers that start with - is
2106 implementation dependant, and can't be relied upon. */
2107 if (numtype & IS_NUMBER_NEG) {
2108 /* Not totally defensive. assumine that looks_like_num
2109 didn't lie about a - sign */
2110 while (isSPACE(*num_begin))
2112 if (*num_begin == '-')
2116 /* Is it an integer that we could convert with strtoul?
2117 So try it, and if it doesn't set errno then it's pukka.
2118 This should be faster than going atof and then thinking. */
2119 if (((numtype & (IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_NOT_INT))
2120 == IS_NUMBER_TO_INT_BY_STRTOL)
2121 && ((errno = 0), 1) /* always true */
2122 && ((u = Strtoul(num_begin, Null(char**), 10)), 1) /* ditto */
2124 /* If known to be negative, check it didn't undeflow IV
2125 XXX possibly we should put more negative values as NVs
2126 direct rather than go via atof below */
2127 && ((numtype & IS_NUMBER_NEG) ? (u <= (UV)IV_MIN) : 1)) {
2130 if (SvTYPE(sv) < SVt_PVIV)
2131 sv_upgrade(sv, SVt_PVIV);
2134 /* If it's negative must use IV.
2135 IV-over-UV optimisation */
2136 if (numtype & IS_NUMBER_NEG) {
2138 } else if (u <= (UV) IV_MAX) {
2141 /* it didn't overflow, and it was positive. */
2150 /* Hopefully trace flow will optimise this away where possible
2154 /* It wasn't an integer, or it overflowed, or we don't have
2155 strtol. Do things the slow way - check if it's a IV etc. */
2156 d = Atof(SvPVX(sv));
2158 if (SvTYPE(sv) < SVt_PVNV)
2159 sv_upgrade(sv, SVt_PVNV);
2162 if (! numtype && ckWARN(WARN_NUMERIC))
2165 #if defined(USE_LONG_DOUBLE)
2166 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%" PERL_PRIgldbl ")\n",
2167 PTR2UV(sv), SvNVX(sv)));
2169 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%g)\n",
2170 PTR2UV(sv), SvNVX(sv)));
2173 #ifdef NV_PRESERVES_UV
2174 (void)SvIOKp_on(sv);
2176 if (SvNVX(sv) < (NV)IV_MAX + 0.5) {
2177 SvIVX(sv) = I_V(SvNVX(sv));
2178 if ((NV)(SvIVX(sv)) == SvNVX(sv)) {
2181 /* Integer is imprecise. NOK, IOKp */
2183 /* UV will not work better than IV */
2185 if (SvNVX(sv) > (NV)UV_MAX) {
2187 /* Integer is inaccurate. NOK, IOKp, is UV */
2191 SvUVX(sv) = U_V(SvNVX(sv));
2192 /* 0xFFFFFFFFFFFFFFFF not an issue in here, NVs
2193 NV preservse UV so can do correct comparison. */
2194 if ((NV)(SvUVX(sv)) == SvNVX(sv)) {
2198 /* Integer is imprecise. NOK, IOKp, is UV */
2203 #else /* NV_PRESERVES_UV */
2204 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2205 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) {
2206 /* Small enough to preserve all bits. */
2207 (void)SvIOKp_on(sv);
2209 SvIVX(sv) = I_V(SvNVX(sv));
2210 if ((NV)(SvIVX(sv)) == SvNVX(sv))
2212 /* Assumption: first non-preserved integer is < IV_MAX,
2213 this NV is in the preserved range, therefore: */
2214 if (!(U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))
2216 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);
2219 sv_2iuv_non_preserve (sv, numtype);
2220 #endif /* NV_PRESERVES_UV */
2225 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2226 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2229 if (SvTYPE(sv) < SVt_IV)
2230 /* Typically the caller expects that sv_any is not NULL now. */
2231 sv_upgrade(sv, SVt_IV);
2235 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2uv(%"UVuf")\n",
2236 PTR2UV(sv),SvUVX(sv)));
2237 return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv);
2241 Perl_sv_2nv(pTHX_ register SV *sv)
2245 if (SvGMAGICAL(sv)) {
2249 if (SvPOKp(sv) && SvLEN(sv)) {
2250 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2252 return Atof(SvPVX(sv));
2256 return (NV)SvUVX(sv);
2258 return (NV)SvIVX(sv);
2261 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2262 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2268 if (SvTHINKFIRST(sv)) {
2271 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) &&
2272 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2273 return SvNV(tmpstr);
2274 return PTR2NV(SvRV(sv));
2276 if (SvREADONLY(sv) && SvFAKE(sv)) {
2277 sv_force_normal(sv);
2279 if (SvREADONLY(sv) && !SvOK(sv)) {
2280 if (ckWARN(WARN_UNINITIALIZED))
2285 if (SvTYPE(sv) < SVt_NV) {
2286 if (SvTYPE(sv) == SVt_IV)
2287 sv_upgrade(sv, SVt_PVNV);
2289 sv_upgrade(sv, SVt_NV);
2290 #if defined(USE_LONG_DOUBLE)
2292 STORE_NUMERIC_LOCAL_SET_STANDARD();
2293 PerlIO_printf(Perl_debug_log,
2294 "0x%"UVxf" num(%" PERL_PRIgldbl ")\n",
2295 PTR2UV(sv), SvNVX(sv));
2296 RESTORE_NUMERIC_LOCAL();
2300 STORE_NUMERIC_LOCAL_SET_STANDARD();
2301 PerlIO_printf(Perl_debug_log, "0x%"UVxf" num(%g)\n",
2302 PTR2UV(sv), SvNVX(sv));
2303 RESTORE_NUMERIC_LOCAL();
2307 else if (SvTYPE(sv) < SVt_PVNV)
2308 sv_upgrade(sv, SVt_PVNV);
2309 if (SvNOKp(sv) && !(SvIOK(sv) || SvPOK(sv))) {
2312 else if (SvIOKp(sv) &&
2313 (!SvPOKp(sv) || !strchr(SvPVX(sv),'.') || !looks_like_number(sv)))
2315 SvNVX(sv) = SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv);
2316 #ifdef NV_PRESERVES_UV
2319 /* Only set the public NV OK flag if this NV preserves the IV */
2320 /* Check it's not 0xFFFFFFFFFFFFFFFF */
2321 if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv))))
2322 : (SvIVX(sv) == I_V(SvNVX(sv))))
2328 else if (SvPOKp(sv) && SvLEN(sv)) {
2329 if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv))
2331 SvNVX(sv) = Atof(SvPVX(sv));
2332 #ifdef NV_PRESERVES_UV
2335 /* Only set the public NV OK flag if this NV preserves the value in
2336 the PV at least as well as an IV/UV would.
2337 Not sure how to do this 100% reliably. */
2338 /* if that shift count is out of range then Configure's test is
2339 wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS ==
2341 if (((UV)1 << NV_PRESERVES_UV_BITS) >
2342 U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv)))
2343 SvNOK_on(sv); /* Definitely small enough to preserve all bits */
2344 else if (SvNVX(sv) < (NV)IV_MIN || SvNVX(sv) > (NV)UV_MAX) {
2345 /* Definitely too large/small to fit in an integer, so no loss
2346 of precision going to integer in the future via NV */
2349 /* Is it something we can run through strtol etc (ie no
2350 trailing exponent part)? */
2351 int numtype = looks_like_number(sv);
2352 /* XXX probably should cache this if called above */
2355 (IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_TO_INT_BY_STRTOL))) {
2356 /* Can't use strtol etc to convert this string, so don't try */
2359 sv_2inuv_non_preserve (sv, numtype);
2361 #endif /* NV_PRESERVES_UV */
2364 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2366 if (SvTYPE(sv) < SVt_NV)
2367 /* Typically the caller expects that sv_any is not NULL now. */
2368 /* XXX Ilya implies that this is a bug in callers that assume this
2369 and ideally should be fixed. */
2370 sv_upgrade(sv, SVt_NV);
2373 #if defined(USE_LONG_DOUBLE)
2375 STORE_NUMERIC_LOCAL_SET_STANDARD();
2376 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2nv(%" PERL_PRIgldbl ")\n",
2377 PTR2UV(sv), SvNVX(sv));
2378 RESTORE_NUMERIC_LOCAL();
2382 STORE_NUMERIC_LOCAL_SET_STANDARD();
2383 PerlIO_printf(Perl_debug_log, "0x%"UVxf" 1nv(%g)\n",
2384 PTR2UV(sv), SvNVX(sv));
2385 RESTORE_NUMERIC_LOCAL();
2392 S_asIV(pTHX_ SV *sv)
2394 I32 numtype = looks_like_number(sv);
2397 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2398 return Atol(SvPVX(sv));
2400 if (ckWARN(WARN_NUMERIC))
2403 d = Atof(SvPVX(sv));
2408 S_asUV(pTHX_ SV *sv)
2410 I32 numtype = looks_like_number(sv);
2413 if (numtype & IS_NUMBER_TO_INT_BY_ATOL)
2414 return Strtoul(SvPVX(sv), Null(char**), 10);
2417 if (ckWARN(WARN_NUMERIC))
2420 return U_V(Atof(SvPVX(sv)));
2424 * Returns a combination of (advisory only - can get false negatives)
2425 * IS_NUMBER_TO_INT_BY_ATOL, IS_NUMBER_TO_INT_BY_ATOF
2426 * IS_NUMBER_LONGER_THAN_IV_MAX, IS_NUMBER_AS_LONG_AS_IV_MAX
2427 * IS_NUMBER_NOT_INT, IS_NUMBER_NEG, IS_NUMBER_INFINITY
2428 * 0 if does not look like number.
2430 * (atol and strtol stop when they hit a decimal point. strtol will return
2431 * LONG_MAX and LONG_MIN when given out of range values. ANSI says they should
2432 * do this, and vendors have had 11 years to get it right.
2433 * However, will try to make it still work with only atol
2435 * IS_NUMBER_TO_INT_BY_ATOL 123456789 or 123456789.3 definitely < IV_MAX
2436 * IS_NUMBER_TO_INT_BY_STRTOL 123456789 or 123456789.3 if digits = IV_MAX
2437 * IS_NUMBER_TO_INT_BY_ATOF 123456789e0 or >> IV_MAX
2438 * IS_NUMBER_LONGER_THAN_IV_MAX lots of digits, don't bother with atol
2439 * IS_NUMBER_AS_LONG_AS_IV_MAX atol might hit LONG_MAX, might not.
2440 * IS_NUMBER_NOT_INT saw "." or "e"
2442 * IS_NUMBER_INFINITY
2446 =for apidoc looks_like_number
2448 Test if an the content of an SV looks like a number (or is a
2449 number). C<Inf> and C<Infinity> are treated as numbers (so will not
2450 issue a non-numeric warning), even if your atof() doesn't grok them.
2456 Perl_looks_like_number(pTHX_ SV *sv)
2459 register char *send;
2460 register char *sbegin;
2461 register char *nbegin;
2465 #ifdef USE_LOCALE_NUMERIC
2466 bool specialradix = FALSE;
2473 else if (SvPOKp(sv))
2474 sbegin = SvPV(sv, len);
2477 send = sbegin + len;
2484 numtype = IS_NUMBER_NEG;
2491 * we return IS_NUMBER_TO_INT_BY_ATOL if the number can converted to
2492 * integer with atol() without overflow, IS_NUMBER_TO_INT_BY_STRTOL if
2493 * possibly slightly larger than max int, IS_NUMBER_TO_INT_BY_ATOF if you
2494 * will need (int)atof().
2497 /* next must be digit or the radix separator or beginning of infinity */
2501 } while (isDIGIT(*s));
2503 /* Aaargh. long long really is irritating.
2504 In the gospel according to ANSI 1989, it is an axiom that "long"
2505 is the longest integer type, and that if you don't know how long
2506 something is you can cast it to long, and nothing will be lost
2507 (except possibly speed of execution if long is slower than the
2509 Now, one can't be sure if the old rules apply, or long long
2510 (or some other newfangled thing) is actually longer than the
2511 (formerly) longest thing.
2513 /* This lot will work for 64 bit *as long as* either
2514 either long is 64 bit
2515 or we can find both strtol/strtoq and strtoul/strtouq
2516 If not, we really should refuse to let the user use 64 bit IVs
2517 By "64 bit" I really mean IVs that don't get preserved by NVs
2518 It also should work for 128 bit IVs. Can any lend me a machine to
2521 if (s - nbegin > TYPE_DIGITS(UV)) /* Cannot cache ato[ul]() */
2522 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_LONGER_THAN_IV_MAX;
2523 else if (s - nbegin < BIT_DIGITS(((sizeof (IV)>sizeof (long))
2524 ? sizeof(long) : sizeof (IV))*8-1))
2525 numtype |= IS_NUMBER_TO_INT_BY_ATOL;
2527 /* Can't be sure either way. (For 64 bit UV, 63 bit IV is 1 decimal
2528 digit less (IV_MAX= 9223372036854775807,
2529 UV_MAX= 18446744073709551615) so be cautious */
2530 numtype |= IS_NUMBER_TO_INT_BY_STRTOL | IS_NUMBER_AS_LONG_AS_IV_MAX;
2533 #ifdef USE_LOCALE_NUMERIC
2534 (specialradix = IS_NUMERIC_RADIX(s, send)) ||
2537 #ifdef USE_LOCALE_NUMERIC
2539 s += SvCUR(PL_numeric_radix_sv);
2543 numtype |= IS_NUMBER_NOT_INT;
2544 while (isDIGIT(*s)) /* optional digits after the radix */
2549 #ifdef USE_LOCALE_NUMERIC
2550 (specialradix = IS_NUMERIC_RADIX(s, send)) ||
2554 #ifdef USE_LOCALE_NUMERIC
2556 s += SvCUR(PL_numeric_radix_sv);
2560 numtype |= IS_NUMBER_TO_INT_BY_ATOL | IS_NUMBER_NOT_INT;
2561 /* no digits before the radix means we need digits after it */
2565 } while (isDIGIT(*s));
2570 else if (*s == 'I' || *s == 'i') {
2571 s++; if (*s != 'N' && *s != 'n') return 0;
2572 s++; if (*s != 'F' && *s != 'f') return 0;
2573 s++; if (*s == 'I' || *s == 'i') {
2574 s++; if (*s != 'N' && *s != 'n') return 0;
2575 s++; if (*s != 'I' && *s != 'i') return 0;
2576 s++; if (*s != 'T' && *s != 't') return 0;
2577 s++; if (*s != 'Y' && *s != 'y') return 0;
2586 numtype = (numtype & IS_NUMBER_NEG) /* Keep track of sign */
2587 | IS_NUMBER_INFINITY | IS_NUMBER_NOT_INT;
2589 /* we can have an optional exponent part */
2590 if (*s == 'e' || *s == 'E') {
2591 numtype &= IS_NUMBER_NEG;
2592 numtype |= IS_NUMBER_TO_INT_BY_ATOF | IS_NUMBER_NOT_INT;
2594 if (*s == '+' || *s == '-')
2599 } while (isDIGIT(*s));
2609 if (len == 10 && memEQ(sbegin, "0 but true", 10))
2610 return IS_NUMBER_TO_INT_BY_ATOL;
2615 Perl_sv_2pv_nolen(pTHX_ register SV *sv)
2618 return sv_2pv(sv, &n_a);
2621 /* We assume that buf is at least TYPE_CHARS(UV) long. */
2623 uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob)
2625 char *ptr = buf + TYPE_CHARS(UV);
2639 *--ptr = '0' + (uv % 10);
2648 Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp)
2650 return sv_2pv_flags(sv, lp, SV_GMAGIC);
2654 Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags)
2659 char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */
2660 char *tmpbuf = tbuf;
2666 if (SvGMAGICAL(sv)) {
2667 if (flags & SV_GMAGIC)
2675 (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv));
2677 (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv));
2682 Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf);
2687 if (!(SvFLAGS(sv) & SVs_PADTMP)) {
2688 if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing)
2695 if (SvTHINKFIRST(sv)) {
2698 if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,string)) &&
2699 (SvTYPE(tmpstr) != SVt_RV || (SvRV(tmpstr) != SvRV(sv))))
2700 return SvPV(tmpstr,*lp);
2707 switch (SvTYPE(sv)) {
2709 if ( ((SvFLAGS(sv) &
2710 (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG))
2711 == (SVs_OBJECT|SVs_RMG))
2712 && strEQ(s=HvNAME(SvSTASH(sv)), "Regexp")
2713 && (mg = mg_find(sv, PERL_MAGIC_qr))) {
2714 regexp *re = (regexp *)mg->mg_obj;
2717 char *fptr = "msix";
2722 U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12;
2724 while((ch = *fptr++)) {
2726 reflags[left++] = ch;
2729 reflags[right--] = ch;
2734 reflags[left] = '-';
2738 mg->mg_len = re->prelen + 4 + left;
2739 New(616, mg->mg_ptr, mg->mg_len + 1 + left, char);
2740 Copy("(?", mg->mg_ptr, 2, char);
2741 Copy(reflags, mg->mg_ptr+2, left, char);
2742 Copy(":", mg->mg_ptr+left+2, 1, char);
2743 Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char);
2744 mg->mg_ptr[mg->mg_len - 1] = ')';
2745 mg->mg_ptr[mg->mg_len] = 0;
2747 PL_reginterp_cnt += re->program[0].next_off;
2759 case SVt_PVBM: if (SvROK(sv))
2762 s = "SCALAR"; break;
2763 case SVt_PVLV: s = "LVALUE"; break;
2764 case SVt_PVAV: s = "ARRAY"; break;
2765 case SVt_PVHV: s = "HASH"; break;
2766 case SVt_PVCV: s = "CODE"; break;
2767 case SVt_PVGV: s = "GLOB"; break;
2768 case SVt_PVFM: s = "FORMAT"; break;
2769 case SVt_PVIO: s = "IO"; break;
2770 default: s = "UNKNOWN"; break;
2774 Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s);
2777 Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv));
2783 if (SvREADONLY(sv) && !SvOK(sv)) {
2784 if (ckWARN(WARN_UNINITIALIZED))
2790 if (SvIOK(sv) || ((SvIOKp(sv) && !SvNOKp(sv)))) {
2791 /* I'm assuming that if both IV and NV are equally valid then
2792 converting the IV is going to be more efficient */
2793 U32 isIOK = SvIOK(sv);
2794 U32 isUIOK = SvIsUV(sv);
2795 char buf[TYPE_CHARS(UV)];
2798 if (SvTYPE(sv) < SVt_PVIV)
2799 sv_upgrade(sv, SVt_PVIV);
2801 ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf);
2803 ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf);
2804 SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */
2805 Move(ptr,SvPVX(sv),ebuf - ptr,char);
2806 SvCUR_set(sv, ebuf - ptr);
2816 else if (SvNOKp(sv)) {
2817 if (SvTYPE(sv) < SVt_PVNV)
2818 sv_upgrade(sv, SVt_PVNV);
2819 /* The +20 is pure guesswork. Configure test needed. --jhi */
2820 SvGROW(sv, NV_DIG + 20);
2822 olderrno = errno; /* some Xenix systems wipe out errno here */
2824 if (SvNVX(sv) == 0.0)
2825 (void)strcpy(s,"0");
2829 Gconvert(SvNVX(sv), NV_DIG, 0, s);
2832 #ifdef FIXNEGATIVEZERO
2833 if (*s == '-' && s[1] == '0' && !s[2])
2843 if (ckWARN(WARN_UNINITIALIZED)
2844 && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP))
2847 if (SvTYPE(sv) < SVt_PV)
2848 /* Typically the caller expects that sv_any is not NULL now. */
2849 sv_upgrade(sv, SVt_PV);
2852 *lp = s - SvPVX(sv);
2855 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
2856 PTR2UV(sv),SvPVX(sv)));
2860 if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */
2861 /* Sneaky stuff here */
2865 tsv = newSVpv(tmpbuf, 0);
2881 len = strlen(tmpbuf);
2883 #ifdef FIXNEGATIVEZERO
2884 if (len == 2 && t[0] == '-' && t[1] == '0') {
2889 (void)SvUPGRADE(sv, SVt_PV);
2891 s = SvGROW(sv, len + 1);
2900 Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv)
2903 return sv_2pvbyte(sv, &n_a);
2907 Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp)
2909 sv_utf8_downgrade(sv,0);
2910 return SvPV(sv,*lp);
2914 Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv)
2917 return sv_2pvutf8(sv, &n_a);
2921 Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp)
2923 sv_utf8_upgrade(sv);
2924 return SvPV(sv,*lp);
2927 /* This function is only called on magical items */
2929 Perl_sv_2bool(pTHX_ register SV *sv)
2938 if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) &&
2939 (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(sv))))
2940 return SvTRUE(tmpsv);
2941 return SvRV(sv) != 0;
2944 register XPV* Xpvtmp;
2945 if ((Xpvtmp = (XPV*)SvANY(sv)) &&
2946 (*Xpvtmp->xpv_pv > '0' ||
2947 Xpvtmp->xpv_cur > 1 ||
2948 (Xpvtmp->xpv_cur && *Xpvtmp->xpv_pv != '0')))
2955 return SvIVX(sv) != 0;
2958 return SvNVX(sv) != 0.0;
2966 =for apidoc sv_utf8_upgrade
2968 Convert the PV of an SV to its UTF8-encoded form.
2969 Forces the SV to string form it it is not already.
2970 Always sets the SvUTF8 flag to avoid future validity checks even
2971 if all the bytes have hibit clear.
2977 Perl_sv_utf8_upgrade(pTHX_ register SV *sv)
2979 return sv_utf8_upgrade_flags(sv, SV_GMAGIC);
2983 =for apidoc sv_utf8_upgrade_flags
2985 Convert the PV of an SV to its UTF8-encoded form.
2986 Forces the SV to string form it it is not already.
2987 Always sets the SvUTF8 flag to avoid future validity checks even
2988 if all the bytes have hibit clear. If C<flags> has C<SV_GMAGIC> bit set,
2989 will C<mg_get> on C<sv> if appropriate, else not. C<sv_utf8_upgrade> and
2990 C<sv_utf8_upgrade_nomg> are implemented in terms of this function.
2996 Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags)
3006 (void) sv_2pv_flags(sv,&len, flags);
3014 if (SvREADONLY(sv) && SvFAKE(sv)) {
3015 sv_force_normal(sv);
3018 /* This function could be much more efficient if we had a FLAG in SVs
3019 * to signal if there are any hibit chars in the PV.
3020 * Given that there isn't make loop fast as possible
3022 s = (U8 *) SvPVX(sv);
3023 e = (U8 *) SvEND(sv);
3027 if ((hibit = !NATIVE_IS_INVARIANT(ch)))
3033 len = SvCUR(sv) + 1; /* Plus the \0 */
3034 SvPVX(sv) = (char*)bytes_to_utf8((U8*)s, &len);
3035 SvCUR(sv) = len - 1;
3037 Safefree(s); /* No longer using what was there before. */
3038 SvLEN(sv) = len; /* No longer know the real size. */
3040 /* Mark as UTF-8 even if no hibit - saves scanning loop */
3046 =for apidoc sv_utf8_downgrade
3048 Attempt to convert the PV of an SV from UTF8-encoded to byte encoding.
3049 This may not be possible if the PV contains non-byte encoding characters;
3050 if this is the case, either returns false or, if C<fail_ok> is not
3057 Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok)
3059 if (SvPOK(sv) && SvUTF8(sv)) {
3064 if (SvREADONLY(sv) && SvFAKE(sv))
3065 sv_force_normal(sv);
3066 s = (U8 *) SvPV(sv, len);
3067 if (!utf8_to_bytes(s, &len)) {
3070 #ifdef USE_BYTES_DOWNGRADES
3071 else if (IN_BYTES) {
3073 U8 *e = (U8 *) SvEND(sv);
3076 UV ch = utf8n_to_uvchr(s,(e-s),&len,0);
3077 if (first && ch > 255) {
3079 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte %s",
3080 PL_op_desc[PL_op->op_type]);
3082 Perl_warner(aTHX_ WARN_UTF8, "Wide character in byte");
3089 len = (d - (U8 *) SvPVX(sv));
3094 Perl_croak(aTHX_ "Wide character in %s",
3095 PL_op_desc[PL_op->op_type]);
3097 Perl_croak(aTHX_ "Wide character");
3108 =for apidoc sv_utf8_encode
3110 Convert the PV of an SV to UTF8-encoded, but then turn off the C<SvUTF8>
3111 flag so that it looks like octets again. Used as a building block
3112 for encode_utf8 in Encode.xs
3118 Perl_sv_utf8_encode(pTHX_ register SV *sv)
3120 (void) sv_utf8_upgrade(sv);
3125 =for apidoc sv_utf8_decode
3127 Convert the octets in the PV from UTF-8 to chars. Scan for validity and then
3128 turn of SvUTF8 if needed so that we see characters. Used as a building block
3129 for decode_utf8 in Encode.xs
3137 Perl_sv_utf8_decode(pTHX_ register SV *sv)
3143 /* The octets may have got themselves encoded - get them back as bytes */
3144 if (!sv_utf8_downgrade(sv, TRUE))
3147 /* it is actually just a matter of turning the utf8 flag on, but
3148 * we want to make sure everything inside is valid utf8 first.
3150 c = (U8 *) SvPVX(sv);
3151 if (!is_utf8_string(c, SvCUR(sv)+1))
3153 e = (U8 *) SvEND(sv);
3156 if (!UTF8_IS_INVARIANT(ch)) {
3166 /* Note: sv_setsv() should not be called with a source string that needs
3167 * to be reused, since it may destroy the source string if it is marked
3172 =for apidoc sv_setsv
3174 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3175 The source SV may be destroyed if it is mortal. Does not handle 'set'
3176 magic. See the macro forms C<SvSetSV>, C<SvSetSV_nosteal> and
3182 /* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided
3183 for binary compatibility only
3186 Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr)
3188 sv_setsv_flags(dstr, sstr, SV_GMAGIC);
3192 =for apidoc sv_setsv_flags
3194 Copies the contents of the source SV C<ssv> into the destination SV C<dsv>.
3195 The source SV may be destroyed if it is mortal. Does not handle 'set'
3196 magic. If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<ssv> if
3197 appropriate, else not. C<sv_setsv> and C<sv_setsv_nomg> are implemented
3198 in terms of this function.
3204 Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags)
3206 register U32 sflags;
3212 SV_CHECK_THINKFIRST(dstr);
3214 sstr = &PL_sv_undef;
3215 stype = SvTYPE(sstr);
3216 dtype = SvTYPE(dstr);
3220 /* There's a lot of redundancy below but we're going for speed here */
3225 if (dtype != SVt_PVGV) {
3226 (void)SvOK_off(dstr);
3234 sv_upgrade(dstr, SVt_IV);
3237 sv_upgrade(dstr, SVt_PVNV);
3241 sv_upgrade(dstr, SVt_PVIV);
3244 (void)SvIOK_only(dstr);
3245 SvIVX(dstr) = SvIVX(sstr);
3248 if (SvTAINTED(sstr))
3259 sv_upgrade(dstr, SVt_NV);
3264 sv_upgrade(dstr, SVt_PVNV);
3267 SvNVX(dstr) = SvNVX(sstr);
3268 (void)SvNOK_only(dstr);
3269 if (SvTAINTED(sstr))
3277 sv_upgrade(dstr, SVt_RV);
3278 else if (dtype == SVt_PVGV &&
3279 SvTYPE(SvRV(sstr)) == SVt_PVGV) {
3282 if (GvIMPORTED(dstr) != GVf_IMPORTED
3283 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3285 GvIMPORTED_on(dstr);
3296 sv_upgrade(dstr, SVt_PV);
3299 if (dtype < SVt_PVIV)
3300 sv_upgrade(dstr, SVt_PVIV);
3303 if (dtype < SVt_PVNV)
3304 sv_upgrade(dstr, SVt_PVNV);
3311 Perl_croak(aTHX_ "Bizarre copy of %s in %s", sv_reftype(sstr, 0),
3312 PL_op_name[PL_op->op_type]);
3314 Perl_croak(aTHX_ "Bizarre copy of %s", sv_reftype(sstr, 0));
3318 if (dtype <= SVt_PVGV) {
3320 if (dtype != SVt_PVGV) {
3321 char *name = GvNAME(sstr);
3322 STRLEN len = GvNAMELEN(sstr);
3323 sv_upgrade(dstr, SVt_PVGV);
3324 sv_magic(dstr, dstr, PERL_MAGIC_glob, Nullch, 0);
3325 GvSTASH(dstr) = (HV*)SvREFCNT_inc(GvSTASH(sstr));
3326 GvNAME(dstr) = savepvn(name, len);
3327 GvNAMELEN(dstr) = len;
3328 SvFAKE_on(dstr); /* can coerce to non-glob */
3330 /* ahem, death to those who redefine active sort subs */
3331 else if (PL_curstackinfo->si_type == PERLSI_SORT
3332 && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr)))
3333 Perl_croak(aTHX_ "Can't redefine active sort subroutine %s",
3336 #ifdef GV_SHARED_CHECK
3337 if (GvSHARED((GV*)dstr)) {
3338 Perl_croak(aTHX_ PL_no_modify);
3342 (void)SvOK_off(dstr);
3343 GvINTRO_off(dstr); /* one-shot flag */
3345 GvGP(dstr) = gp_ref(GvGP(sstr));
3346 if (SvTAINTED(sstr))
3348 if (GvIMPORTED(dstr) != GVf_IMPORTED
3349 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3351 GvIMPORTED_on(dstr);
3359 if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
3361 if (SvTYPE(sstr) != stype) {
3362 stype = SvTYPE(sstr);
3363 if (stype == SVt_PVGV && dtype <= SVt_PVGV)
3367 if (stype == SVt_PVLV)
3368 (void)SvUPGRADE(dstr, SVt_PVNV);
3370 (void)SvUPGRADE(dstr, stype);
3373 sflags = SvFLAGS(sstr);
3375 if (sflags & SVf_ROK) {
3376 if (dtype >= SVt_PV) {
3377 if (dtype == SVt_PVGV) {
3378 SV *sref = SvREFCNT_inc(SvRV(sstr));
3380 int intro = GvINTRO(dstr);
3382 #ifdef GV_SHARED_CHECK
3383 if (GvSHARED((GV*)dstr)) {
3384 Perl_croak(aTHX_ PL_no_modify);
3391 GvINTRO_off(dstr); /* one-shot flag */
3392 Newz(602,gp, 1, GP);
3393 GvGP(dstr) = gp_ref(gp);
3394 GvSV(dstr) = NEWSV(72,0);
3395 GvLINE(dstr) = CopLINE(PL_curcop);
3396 GvEGV(dstr) = (GV*)dstr;
3399 switch (SvTYPE(sref)) {
3402 SAVESPTR(GvAV(dstr));
3404 dref = (SV*)GvAV(dstr);
3405 GvAV(dstr) = (AV*)sref;
3406 if (!GvIMPORTED_AV(dstr)
3407 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3409 GvIMPORTED_AV_on(dstr);
3414 SAVESPTR(GvHV(dstr));
3416 dref = (SV*)GvHV(dstr);
3417 GvHV(dstr) = (HV*)sref;
3418 if (!GvIMPORTED_HV(dstr)
3419 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3421 GvIMPORTED_HV_on(dstr);
3426 if (GvCVGEN(dstr) && GvCV(dstr) != (CV*)sref) {
3427 SvREFCNT_dec(GvCV(dstr));
3428 GvCV(dstr) = Nullcv;
3429 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3430 PL_sub_generation++;
3432 SAVESPTR(GvCV(dstr));
3435 dref = (SV*)GvCV(dstr);
3436 if (GvCV(dstr) != (CV*)sref) {
3437 CV* cv = GvCV(dstr);
3439 if (!GvCVGEN((GV*)dstr) &&
3440 (CvROOT(cv) || CvXSUB(cv)))
3442 /* ahem, death to those who redefine
3443 * active sort subs */
3444 if (PL_curstackinfo->si_type == PERLSI_SORT &&
3445 PL_sortcop == CvSTART(cv))
3447 "Can't redefine active sort subroutine %s",
3448 GvENAME((GV*)dstr));
3449 /* Redefining a sub - warning is mandatory if
3450 it was a const and its value changed. */
3451 if (ckWARN(WARN_REDEFINE)
3453 && (!CvCONST((CV*)sref)
3454 || sv_cmp(cv_const_sv(cv),
3455 cv_const_sv((CV*)sref)))))
3457 Perl_warner(aTHX_ WARN_REDEFINE,
3459 ? "Constant subroutine %s redefined"
3460 : "Subroutine %s redefined",
3461 GvENAME((GV*)dstr));
3464 cv_ckproto(cv, (GV*)dstr,
3465 SvPOK(sref) ? SvPVX(sref) : Nullch);
3467 GvCV(dstr) = (CV*)sref;
3468 GvCVGEN(dstr) = 0; /* Switch off cacheness. */
3469 GvASSUMECV_on(dstr);
3470 PL_sub_generation++;
3472 if (!GvIMPORTED_CV(dstr)
3473 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3475 GvIMPORTED_CV_on(dstr);
3480 SAVESPTR(GvIOp(dstr));
3482 dref = (SV*)GvIOp(dstr);
3483 GvIOp(dstr) = (IO*)sref;
3487 SAVESPTR(GvFORM(dstr));
3489 dref = (SV*)GvFORM(dstr);
3490 GvFORM(dstr) = (CV*)sref;
3494 SAVESPTR(GvSV(dstr));
3496 dref = (SV*)GvSV(dstr);
3498 if (!GvIMPORTED_SV(dstr)
3499 && CopSTASH_ne(PL_curcop, GvSTASH(dstr)))
3501 GvIMPORTED_SV_on(dstr);
3509 if (SvTAINTED(sstr))
3514 (void)SvOOK_off(dstr); /* backoff */
3516 Safefree(SvPVX(dstr));
3517 SvLEN(dstr)=SvCUR(dstr)=0;
3520 (void)SvOK_off(dstr);
3521 SvRV(dstr) = SvREFCNT_inc(SvRV(sstr));
3523 if (sflags & SVp_NOK) {
3525 /* Only set the public OK flag if the source has public OK. */
3526 if (sflags & SVf_NOK)
3527 SvFLAGS(dstr) |= SVf_NOK;
3528 SvNVX(dstr) = SvNVX(sstr);
3530 if (sflags & SVp_IOK) {
3531 (void)SvIOKp_on(dstr);
3532 if (sflags & SVf_IOK)
3533 SvFLAGS(dstr) |= SVf_IOK;
3534 if (sflags & SVf_IVisUV)
3536 SvIVX(dstr) = SvIVX(sstr);
3538 if (SvAMAGIC(sstr)) {
3542 else if (sflags & SVp_POK) {
3545 * Check to see if we can just swipe the string. If so, it's a
3546 * possible small lose on short strings, but a big win on long ones.
3547 * It might even be a win on short strings if SvPVX(dstr)
3548 * has to be allocated and SvPVX(sstr) has to be freed.
3551 if (SvTEMP(sstr) && /* slated for free anyway? */
3552 SvREFCNT(sstr) == 1 && /* and no other references to it? */
3553 !(sflags & SVf_OOK) && /* and not involved in OOK hack? */
3554 SvLEN(sstr) && /* and really is a string */
3555 !(PL_op && PL_op->op_type == OP_AASSIGN)) /* and won't be needed again, potentially */
3557 if (SvPVX(dstr)) { /* we know that dtype >= SVt_PV */
3559 SvFLAGS(dstr) &= ~SVf_OOK;
3560 Safefree(SvPVX(dstr) - SvIVX(dstr));
3562 else if (SvLEN(dstr))
3563 Safefree(SvPVX(dstr));
3565 (void)SvPOK_only(dstr);
3566 SvPV_set(dstr, SvPVX(sstr));
3567 SvLEN_set(dstr, SvLEN(sstr));
3568 SvCUR_set(dstr, SvCUR(sstr));
3571 (void)SvOK_off(sstr); /* NOTE: nukes most SvFLAGS on sstr */
3572 SvPV_set(sstr, Nullch);
3577 else { /* have to copy actual string */
3578 STRLEN len = SvCUR(sstr);
3580 SvGROW(dstr, len + 1); /* inlined from sv_setpvn */
3581 Move(SvPVX(sstr),SvPVX(dstr),len,char);
3582 SvCUR_set(dstr, len);
3583 *SvEND(dstr) = '\0';
3584 (void)SvPOK_only(dstr);
3586 if (sflags & SVf_UTF8)
3589 if (sflags & SVp_NOK) {
3591 if (sflags & SVf_NOK)
3592 SvFLAGS(dstr) |= SVf_NOK;
3593 SvNVX(dstr) = SvNVX(sstr);
3595 if (sflags & SVp_IOK) {
3596 (void)SvIOKp_on(dstr);
3597 if (sflags & SVf_IOK)
3598 SvFLAGS(dstr) |= SVf_IOK;
3599 if (sflags & SVf_IVisUV)
3601 SvIVX(dstr) = SvIVX(sstr);
3604 else if (sflags & SVp_IOK) {
3605 if (sflags & SVf_IOK)
3606 (void)SvIOK_only(dstr);
3608 (void)SvOK_off(dstr);
3609 (void)SvIOKp_on(dstr);
3611 /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */
3612 if (sflags & SVf_IVisUV)
3614 SvIVX(dstr) = SvIVX(sstr);
3615 if (sflags & SVp_NOK) {
3616 if (sflags & SVf_NOK)
3617 (void)SvNOK_on(dstr);
3619 (void)SvNOKp_on(dstr);
3620 SvNVX(dstr) = SvNVX(sstr);
3623 else if (sflags & SVp_NOK) {
3624 if (sflags & SVf_NOK)
3625 (void)SvNOK_only(dstr);
3627 (void)SvOK_off(dstr);
3630 SvNVX(dstr) = SvNVX(sstr);
3633 if (dtype == SVt_PVGV) {
3634 if (ckWARN(WARN_MISC))
3635 Perl_warner(aTHX_ WARN_MISC, "Undefined value assigned to typeglob");
3638 (void)SvOK_off(dstr);
3640 if (SvTAINTED(sstr))
3645 =for apidoc sv_setsv_mg
3647 Like C<sv_setsv>, but also handles 'set' magic.
3653 Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr)
3655 sv_setsv(dstr,sstr);
3660 =for apidoc sv_setpvn
3662 Copies a string into an SV. The C<len> parameter indicates the number of
3663 bytes to be copied. Does not handle 'set' magic. See C<sv_setpvn_mg>.
3669 Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3671 register char *dptr;
3673 SV_CHECK_THINKFIRST(sv);
3679 /* len is STRLEN which is unsigned, need to copy to signed */
3682 Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen");
3684 (void)SvUPGRADE(sv, SVt_PV);
3686 SvGROW(sv, len + 1);
3688 Move(ptr,dptr,len,char);
3691 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3696 =for apidoc sv_setpvn_mg
3698 Like C<sv_setpvn>, but also handles 'set' magic.
3704 Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3706 sv_setpvn(sv,ptr,len);
3711 =for apidoc sv_setpv
3713 Copies a string into an SV. The string must be null-terminated. Does not
3714 handle 'set' magic. See C<sv_setpv_mg>.
3720 Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr)
3722 register STRLEN len;
3724 SV_CHECK_THINKFIRST(sv);
3730 (void)SvUPGRADE(sv, SVt_PV);
3732 SvGROW(sv, len + 1);
3733 Move(ptr,SvPVX(sv),len+1,char);
3735 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3740 =for apidoc sv_setpv_mg
3742 Like C<sv_setpv>, but also handles 'set' magic.
3748 Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr)
3755 =for apidoc sv_usepvn
3757 Tells an SV to use C<ptr> to find its string value. Normally the string is
3758 stored inside the SV but sv_usepvn allows the SV to use an outside string.
3759 The C<ptr> should point to memory that was allocated by C<malloc>. The
3760 string length, C<len>, must be supplied. This function will realloc the
3761 memory pointed to by C<ptr>, so that pointer should not be freed or used by
3762 the programmer after giving it to sv_usepvn. Does not handle 'set' magic.
3763 See C<sv_usepvn_mg>.
3769 Perl_sv_usepvn(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3771 SV_CHECK_THINKFIRST(sv);
3772 (void)SvUPGRADE(sv, SVt_PV);
3777 (void)SvOOK_off(sv);
3778 if (SvPVX(sv) && SvLEN(sv))
3779 Safefree(SvPVX(sv));
3780 Renew(ptr, len+1, char);
3783 SvLEN_set(sv, len+1);
3785 (void)SvPOK_only_UTF8(sv); /* validate pointer */
3790 =for apidoc sv_usepvn_mg
3792 Like C<sv_usepvn>, but also handles 'set' magic.
3798 Perl_sv_usepvn_mg(pTHX_ register SV *sv, register char *ptr, register STRLEN len)
3800 sv_usepvn(sv,ptr,len);
3805 Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags)
3807 if (SvREADONLY(sv)) {
3809 char *pvx = SvPVX(sv);
3810 STRLEN len = SvCUR(sv);
3811 U32 hash = SvUVX(sv);
3812 SvGROW(sv, len + 1);
3813 Move(pvx,SvPVX(sv),len,char);
3817 unsharepvn(pvx,SvUTF8(sv)?-len:len,hash);
3819 else if (PL_curcop != &PL_compiling)
3820 Perl_croak(aTHX_ PL_no_modify);
3823 sv_unref_flags(sv, flags);
3824 else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
3829 Perl_sv_force_normal(pTHX_ register SV *sv)
3831 sv_force_normal_flags(sv, 0);
3837 Efficient removal of characters from the beginning of the string buffer.
3838 SvPOK(sv) must be true and the C<ptr> must be a pointer to somewhere inside
3839 the string buffer. The C<ptr> becomes the first character of the adjusted
3846 Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) /* like set but assuming ptr is in sv */
3850 register STRLEN delta;
3852 if (!ptr || !SvPOKp(sv))
3854 SV_CHECK_THINKFIRST(sv);
3855 if (SvTYPE(sv) < SVt_PVIV)
3856 sv_upgrade(sv,SVt_PVIV);
3859 if (!SvLEN(sv)) { /* make copy of shared string */
3860 char *pvx = SvPVX(sv);
3861 STRLEN len = SvCUR(sv);
3862 SvGROW(sv, len + 1);
3863 Move(pvx,SvPVX(sv),len,char);
3867 SvFLAGS(sv) |= SVf_OOK;
3869 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVp_IOK|SVp_NOK|SVf_IVisUV);
3870 delta = ptr - SvPVX(sv);
3878 =for apidoc sv_catpvn
3880 Concatenates the string onto the end of the string which is in the SV. The
3881 C<len> indicates number of bytes to copy. If the SV has the UTF8
3882 status set, then the bytes appended should be valid UTF8.
3883 Handles 'get' magic, but not 'set' magic. See C<sv_catpvn_mg>.
3888 /* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided
3889 for binary compatibility only
3892 Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen)
3894 sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC);
3898 =for apidoc sv_catpvn_flags
3900 Concatenates the string onto the end of the string which is in the SV. The
3901 C<len> indicates number of bytes to copy. If the SV has the UTF8
3902 status set, then the bytes appended should be valid UTF8.
3903 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<dsv> if
3904 appropriate, else not. C<sv_catpvn> and C<sv_catpvn_nomg> are implemented
3905 in terms of this function.
3911 Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags)
3916 dstr = SvPV_force_flags(dsv, dlen, flags);
3917 SvGROW(dsv, dlen + slen + 1);
3920 Move(sstr, SvPVX(dsv) + dlen, slen, char);
3923 (void)SvPOK_only_UTF8(dsv); /* validate pointer */
3928 =for apidoc sv_catpvn_mg
3930 Like C<sv_catpvn>, but also handles 'set' magic.
3936 Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len)
3938 sv_catpvn(sv,ptr,len);
3943 =for apidoc sv_catsv
3945 Concatenates the string from SV C<ssv> onto the end of the string in
3946 SV C<dsv>. Modifies C<dsv> but not C<ssv>. Handles 'get' magic, but
3947 not 'set' magic. See C<sv_catsv_mg>.
3951 /* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided
3952 for binary compatibility only
3955 Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr)
3957 sv_catsv_flags(dstr, sstr, SV_GMAGIC);
3961 =for apidoc sv_catsv_flags
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>. If C<flags> has C<SV_GMAGIC>
3965 bit set, will C<mg_get> on the SVs if appropriate, else not. C<sv_catsv>
3966 and C<sv_catsv_nomg> are implemented in terms of this function.
3971 Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags)
3977 if ((spv = SvPV(ssv, slen))) {
3978 bool sutf8 = DO_UTF8(ssv);
3981 if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC))
3983 dutf8 = DO_UTF8(dsv);
3985 if (dutf8 != sutf8) {
3987 /* Not modifying source SV, so taking a temporary copy. */
3988 SV* csv = sv_2mortal(newSVpvn(spv, slen));
3990 sv_utf8_upgrade(csv);
3991 spv = SvPV(csv, slen);
3994 sv_utf8_upgrade_nomg(dsv);
3996 sv_catpvn_nomg(dsv, spv, slen);
4001 =for apidoc sv_catsv_mg
4003 Like C<sv_catsv>, but also handles 'set' magic.
4009 Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv)
4016 =for apidoc sv_catpv
4018 Concatenates the string onto the end of the string which is in the SV.
4019 If the SV has the UTF8 status set, then the bytes appended should be
4020 valid UTF8. Handles 'get' magic, but not 'set' magic. See C<sv_catpv_mg>.
4025 Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr)
4027 register STRLEN len;
4033 junk = SvPV_force(sv, tlen);
4035 SvGROW(sv, tlen + len + 1);
4038 Move(ptr,SvPVX(sv)+tlen,len+1,char);
4040 (void)SvPOK_only_UTF8(sv); /* validate pointer */
4045 =for apidoc sv_catpv_mg
4047 Like C<sv_catpv>, but also handles 'set' magic.
4053 Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr)
4060 Perl_newSV(pTHX_ STRLEN len)
4066 sv_upgrade(sv, SVt_PV);
4067 SvGROW(sv, len + 1);
4072 /* name is assumed to contain an SV* if (name && namelen == HEf_SVKEY) */
4075 =for apidoc sv_magic
4077 Adds magic to an SV.
4083 Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen)
4087 if (SvREADONLY(sv)) {
4088 if (PL_curcop != &PL_compiling
4089 /* XXX this used to be !strchr("gBf", how), which seems to
4090 * implicity be equal to !strchr("gBf\0", how), ie \0 matches
4091 * too. I find this suprising, but have hadded PERL_MAGIC_sv
4092 * to the list of things to check - DAPM 19-May-01 */
4093 && how != PERL_MAGIC_regex_global
4094 && how != PERL_MAGIC_bm
4095 && how != PERL_MAGIC_fm
4096 && how != PERL_MAGIC_sv
4099 Perl_croak(aTHX_ PL_no_modify);
4102 if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) {
4103 if (SvMAGIC(sv) && (mg = mg_find(sv, how))) {
4104 if (how == PERL_MAGIC_taint)
4110 (void)SvUPGRADE(sv, SVt_PVMG);
4112 Newz(702,mg, 1, MAGIC);
4113 mg->mg_moremagic = SvMAGIC(sv);
4116 /* Some magic sontains a reference loop, where the sv and object refer to
4117 each other. To prevent a avoid a reference loop that would prevent such
4118 objects being freed, we look for such loops and if we find one we avoid
4119 incrementing the object refcount. */
4120 if (!obj || obj == sv ||
4121 how == PERL_MAGIC_arylen ||
4122 how == PERL_MAGIC_qr ||
4123 (SvTYPE(obj) == SVt_PVGV &&
4124 (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv ||
4125 GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv ||
4126 GvFORM(obj) == (CV*)sv)))
4131 mg->mg_obj = SvREFCNT_inc(obj);
4132 mg->mg_flags |= MGf_REFCOUNTED;
4135 mg->mg_len = namlen;
4138 mg->mg_ptr = savepvn(name, namlen);
4139 else if (namlen == HEf_SVKEY)
4140 mg->mg_ptr = (char*)SvREFCNT_inc((SV*)name);
4145 mg->mg_virtual = &PL_vtbl_sv;
4147 case PERL_MAGIC_overload:
4148 mg->mg_virtual = &PL_vtbl_amagic;
4150 case PERL_MAGIC_overload_elem:
4151 mg->mg_virtual = &PL_vtbl_amagicelem;
4153 case PERL_MAGIC_overload_table:
4154 mg->mg_virtual = &PL_vtbl_ovrld;
4157 mg->mg_virtual = &PL_vtbl_bm;
4159 case PERL_MAGIC_regdata:
4160 mg->mg_virtual = &PL_vtbl_regdata;
4162 case PERL_MAGIC_regdatum:
4163 mg->mg_virtual = &PL_vtbl_regdatum;
4165 case PERL_MAGIC_env:
4166 mg->mg_virtual = &PL_vtbl_env;
4169 mg->mg_virtual = &PL_vtbl_fm;
4171 case PERL_MAGIC_envelem:
4172 mg->mg_virtual = &PL_vtbl_envelem;
4174 case PERL_MAGIC_regex_global:
4175 mg->mg_virtual = &PL_vtbl_mglob;
4177 case PERL_MAGIC_isa:
4178 mg->mg_virtual = &PL_vtbl_isa;
4180 case PERL_MAGIC_isaelem:
4181 mg->mg_virtual = &PL_vtbl_isaelem;
4183 case PERL_MAGIC_nkeys:
4184 mg->mg_virtual = &PL_vtbl_nkeys;
4186 case PERL_MAGIC_dbfile:
4190 case PERL_MAGIC_dbline:
4191 mg->mg_virtual = &PL_vtbl_dbline;
4194 case PERL_MAGIC_mutex:
4195 mg->mg_virtual = &PL_vtbl_mutex;
4197 #endif /* USE_THREADS */
4198 #ifdef USE_LOCALE_COLLATE
4199 case PERL_MAGIC_collxfrm:
4200 mg->mg_virtual = &PL_vtbl_collxfrm;
4202 #endif /* USE_LOCALE_COLLATE */
4203 case PERL_MAGIC_tied:
4204 mg->mg_virtual = &PL_vtbl_pack;
4206 case PERL_MAGIC_tiedelem:
4207 case PERL_MAGIC_tiedscalar:
4208 mg->mg_virtual = &PL_vtbl_packelem;
4211 mg->mg_virtual = &PL_vtbl_regexp;
4213 case PERL_MAGIC_sig:
4214 mg->mg_virtual = &PL_vtbl_sig;
4216 case PERL_MAGIC_sigelem:
4217 mg->mg_virtual = &PL_vtbl_sigelem;
4219 case PERL_MAGIC_taint:
4220 mg->mg_virtual = &PL_vtbl_taint;
4223 case PERL_MAGIC_uvar:
4224 mg->mg_virtual = &PL_vtbl_uvar;
4226 case PERL_MAGIC_vec:
4227 mg->mg_virtual = &PL_vtbl_vec;
4229 case PERL_MAGIC_substr:
4230 mg->mg_virtual = &PL_vtbl_substr;
4232 case PERL_MAGIC_defelem:
4233 mg->mg_virtual = &PL_vtbl_defelem;
4235 case PERL_MAGIC_glob:
4236 mg->mg_virtual = &PL_vtbl_glob;
4238 case PERL_MAGIC_arylen:
4239 mg->mg_virtual = &PL_vtbl_arylen;
4241 case PERL_MAGIC_pos:
4242 mg->mg_virtual = &PL_vtbl_pos;
4244 case PERL_MAGIC_backref:
4245 mg->mg_virtual = &PL_vtbl_backref;
4247 case PERL_MAGIC_ext:
4248 /* Reserved for use by extensions not perl internals. */
4249 /* Useful for attaching extension internal data to perl vars. */
4250 /* Note that multiple extensions may clash if magical scalars */
4251 /* etc holding private data from one are passed to another. */
4255 Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how);
4259 SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK|SVf_POK);
4263 =for apidoc sv_unmagic
4265 Removes magic from an SV.
4271 Perl_sv_unmagic(pTHX_ SV *sv, int type)
4275 if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv))
4278 for (mg = *mgp; mg; mg = *mgp) {
4279 if (mg->mg_type == type) {
4280 MGVTBL* vtbl = mg->mg_virtual;
4281 *mgp = mg->mg_moremagic;
4282 if (vtbl && vtbl->svt_free)
4283 CALL_FPTR(vtbl->svt_free)(aTHX_ sv, mg);
4284 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
4285 if (mg->mg_len >= 0)
4286 Safefree(mg->mg_ptr);
4287 else if (mg->mg_len == HEf_SVKEY)
4288 SvREFCNT_dec((SV*)mg->mg_ptr);
4290 if (mg->mg_flags & MGf_REFCOUNTED)
4291 SvREFCNT_dec(mg->mg_obj);
4295 mgp = &mg->mg_moremagic;
4299 SvFLAGS(sv) |= (SvFLAGS(sv) & (SVp_NOK|SVp_POK)) >> PRIVSHIFT;
4306 =for apidoc sv_rvweaken
4314 Perl_sv_rvweaken(pTHX_ SV *sv)
4317 if (!SvOK(sv)) /* let undefs pass */
4320 Perl_croak(aTHX_ "Can't weaken a nonreference");
4321 else if (SvWEAKREF(sv)) {
4322 if (ckWARN(WARN_MISC))
4323 Perl_warner(aTHX_ WARN_MISC, "Reference is already weak");
4327 sv_add_backref(tsv, sv);
4334 S_sv_add_backref(pTHX_ SV *tsv, SV *sv)
4338 if (SvMAGICAL(tsv) && (mg = mg_find(tsv, PERL_MAGIC_backref)))
4339 av = (AV*)mg->mg_obj;
4342 sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0);
4343 SvREFCNT_dec(av); /* for sv_magic */
4349 S_sv_del_backref(pTHX_ SV *sv)
4356 if (!SvMAGICAL(tsv) || !(mg = mg_find(tsv, PERL_MAGIC_backref)))
4357 Perl_croak(aTHX_ "panic: del_backref");
4358 av = (AV *)mg->mg_obj;
4363 svp[i] = &PL_sv_undef; /* XXX */
4370 =for apidoc sv_insert
4372 Inserts a string at the specified offset/length within the SV. Similar to
4373 the Perl substr() function.
4379 Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, char *little, STRLEN littlelen)
4383 register char *midend;
4384 register char *bigend;
4390 Perl_croak(aTHX_ "Can't modify non-existent substring");
4391 SvPV_force(bigstr, curlen);
4392 (void)SvPOK_only_UTF8(bigstr);
4393 if (offset + len > curlen) {
4394 SvGROW(bigstr, offset+len+1);
4395 Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char);
4396 SvCUR_set(bigstr, offset+len);
4400 i = littlelen - len;
4401 if (i > 0) { /* string might grow */
4402 big = SvGROW(bigstr, SvCUR(bigstr) + i + 1);
4403 mid = big + offset + len;
4404 midend = bigend = big + SvCUR(bigstr);
4407 while (midend > mid) /* shove everything down */
4408 *--bigend = *--midend;
4409 Move(little,big+offset,littlelen,char);
4415 Move(little,SvPVX(bigstr)+offset,len,char);
4420 big = SvPVX(bigstr);
4423 bigend = big + SvCUR(bigstr);
4425 if (midend > bigend)
4426 Perl_croak(aTHX_ "panic: sv_insert");
4428 if (mid - big > bigend - midend) { /* faster to shorten from end */
4430 Move(little, mid, littlelen,char);
4433 i = bigend - midend;
4435 Move(midend, mid, i,char);
4439 SvCUR_set(bigstr, mid - big);
4442 else if ((i = mid - big)) { /* faster from front */
4443 midend -= littlelen;
4445 sv_chop(bigstr,midend-i);
4450 Move(little, mid, littlelen,char);
4452 else if (littlelen) {
4453 midend -= littlelen;
4454 sv_chop(bigstr,midend);
4455 Move(little,midend,littlelen,char);
4458 sv_chop(bigstr,midend);
4464 =for apidoc sv_replace
4466 Make the first argument a copy of the second, then delete the original.
4472 Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv)
4474 U32 refcnt = SvREFCNT(sv);
4475 SV_CHECK_THINKFIRST(sv);
4476 if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL))
4477 Perl_warner(aTHX_ WARN_INTERNAL, "Reference miscount in sv_replace()");
4478 if (SvMAGICAL(sv)) {
4482 sv_upgrade(nsv, SVt_PVMG);
4483 SvMAGIC(nsv) = SvMAGIC(sv);
4484 SvFLAGS(nsv) |= SvMAGICAL(sv);
4490 assert(!SvREFCNT(sv));
4491 StructCopy(nsv,sv,SV);
4492 SvREFCNT(sv) = refcnt;
4493 SvFLAGS(nsv) |= SVTYPEMASK; /* Mark as freed */
4498 =for apidoc sv_clear
4500 Clear an SV, making it empty. Does not free the memory used by the SV
4507 Perl_sv_clear(pTHX_ register SV *sv)
4511 assert(SvREFCNT(sv) == 0);
4514 if (PL_defstash) { /* Still have a symbol table? */
4519 Zero(&tmpref, 1, SV);
4520 sv_upgrade(&tmpref, SVt_RV);
4522 SvREADONLY_on(&tmpref); /* DESTROY() could be naughty */
4523 SvREFCNT(&tmpref) = 1;
4526 stash = SvSTASH(sv);
4527 destructor = StashHANDLER(stash,DESTROY);
4530 PUSHSTACKi(PERLSI_DESTROY);
4531 SvRV(&tmpref) = SvREFCNT_inc(sv);
4536 call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR);
4542 } while (SvOBJECT(sv) && SvSTASH(sv) != stash);
4544 del_XRV(SvANY(&tmpref));
4547 if (PL_in_clean_objs)
4548 Perl_croak(aTHX_ "DESTROY created new reference to dead object '%s'",
4550 /* DESTROY gave object new lease on life */
4556 SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */
4557 SvOBJECT_off(sv); /* Curse the object. */
4558 if (SvTYPE(sv) != SVt_PVIO)
4559 --PL_sv_objcount; /* XXX Might want something more general */
4562 if (SvTYPE(sv) >= SVt_PVMG) {
4565 if (SvFLAGS(sv) & SVpad_TYPED)
4566 SvREFCNT_dec(SvSTASH(sv));
4569 switch (SvTYPE(sv)) {
4572 IoIFP(sv) != PerlIO_stdin() &&
4573 IoIFP(sv) != PerlIO_stdout() &&
4574 IoIFP(sv) != PerlIO_stderr())
4576 io_close((IO*)sv, FALSE);
4578 if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP))
4579 PerlDir_close(IoDIRP(sv));
4580 IoDIRP(sv) = (DIR*)NULL;
4581 Safefree(IoTOP_NAME(sv));
4582 Safefree(IoFMT_NAME(sv));
4583 Safefree(IoBOTTOM_NAME(sv));
4598 SvREFCNT_dec(LvTARG(sv));
4602 Safefree(GvNAME(sv));
4603 /* cannot decrease stash refcount yet, as we might recursively delete
4604 ourselves when the refcnt drops to zero. Delay SvREFCNT_dec
4605 of stash until current sv is completely gone.
4606 -- JohnPC, 27 Mar 1998 */
4607 stash = GvSTASH(sv);
4613 (void)SvOOK_off(sv);
4621 SvREFCNT_dec(SvRV(sv));
4623 else if (SvPVX(sv) && SvLEN(sv))
4624 Safefree(SvPVX(sv));
4625 else if (SvPVX(sv) && SvREADONLY(sv) && SvFAKE(sv)) {
4626 unsharepvn(SvPVX(sv),SvUTF8(sv)?-SvCUR(sv):SvCUR(sv),SvUVX(sv));
4638 switch (SvTYPE(sv)) {
4654 del_XPVIV(SvANY(sv));
4657 del_XPVNV(SvANY(sv));
4660 del_XPVMG(SvANY(sv));
4663 del_XPVLV(SvANY(sv));
4666 del_XPVAV(SvANY(sv));
4669 del_XPVHV(SvANY(sv));
4672 del_XPVCV(SvANY(sv));
4675 del_XPVGV(SvANY(sv));
4676 /* code duplication for increased performance. */
4677 SvFLAGS(sv) &= SVf_BREAK;
4678 SvFLAGS(sv) |= SVTYPEMASK;
4679 /* decrease refcount of the stash that owns this GV, if any */
4681 SvREFCNT_dec(stash);
4682 return; /* not break, SvFLAGS reset already happened */
4684 del_XPVBM(SvANY(sv));
4687 del_XPVFM(SvANY(sv));
4690 del_XPVIO(SvANY(sv));
4693 SvFLAGS(sv) &= SVf_BREAK;
4694 SvFLAGS(sv) |= SVTYPEMASK;
4698 Perl_sv_newref(pTHX_ SV *sv)
4701 ATOMIC_INC(SvREFCNT(sv));
4708 Free the memory used by an SV.
4714 Perl_sv_free(pTHX_ SV *sv)
4716 int refcount_is_zero;
4720 if (SvREFCNT(sv) == 0) {
4721 if (SvFLAGS(sv) & SVf_BREAK)
4723 if (PL_in_clean_all) /* All is fair */
4725 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4726 /* make sure SvREFCNT(sv)==0 happens very seldom */
4727 SvREFCNT(sv) = (~(U32)0)/2;
4730 if (ckWARN_d(WARN_INTERNAL))
4731 Perl_warner(aTHX_ WARN_INTERNAL, "Attempt to free unreferenced scalar");
4734 ATOMIC_DEC_AND_TEST(refcount_is_zero, SvREFCNT(sv));
4735 if (!refcount_is_zero)
4739 if (ckWARN_d(WARN_DEBUGGING))
4740 Perl_warner(aTHX_ WARN_DEBUGGING,
4741 "Attempt to free temp prematurely: SV 0x%"UVxf,
4746 if (SvREADONLY(sv) && SvIMMORTAL(sv)) {
4747 /* make sure SvREFCNT(sv)==0 happens very seldom */
4748 SvREFCNT(sv) = (~(U32)0)/2;
4759 Returns the length of the string in the SV. See also C<SvCUR>.
4765 Perl_sv_len(pTHX_ register SV *sv)
4774 len = mg_length(sv);
4776 junk = SvPV(sv, len);
4781 =for apidoc sv_len_utf8
4783 Returns the number of characters in the string in an SV, counting wide
4784 UTF8 bytes as a single character.
4790 Perl_sv_len_utf8(pTHX_ register SV *sv)
4796 return mg_length(sv);
4800 U8 *s = (U8*)SvPV(sv, len);
4802 return Perl_utf8_length(aTHX_ s, s + len);
4807 Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp)
4812 I32 uoffset = *offsetp;
4818 start = s = (U8*)SvPV(sv, len);
4820 while (s < send && uoffset--)
4824 *offsetp = s - start;
4828 while (s < send && ulen--)
4838 Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp)
4847 s = (U8*)SvPV(sv, len);
4849 Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset");
4850 send = s + *offsetp;
4854 /* Call utf8n_to_uvchr() to validate the sequence */
4855 utf8n_to_uvchr(s, UTF8SKIP(s), &n, 0);
4870 Returns a boolean indicating whether the strings in the two SVs are
4877 Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2)
4891 pv1 = SvPV(sv1, cur1);
4898 pv2 = SvPV(sv2, cur2);
4900 /* do not utf8ize the comparands as a side-effect */
4901 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4902 bool is_utf8 = TRUE;
4903 /* UTF-8ness differs */
4904 if (PL_hints & HINT_UTF8_DISTINCT)
4908 /* sv1 is the UTF-8 one , If is equal it must be downgrade-able */
4909 char *pv = (char*)bytes_from_utf8((U8*)pv1, &cur1, &is_utf8);
4914 /* sv2 is the UTF-8 one , If is equal it must be downgrade-able */
4915 char *pv = (char *)bytes_from_utf8((U8*)pv2, &cur2, &is_utf8);
4920 /* Downgrade not possible - cannot be eq */
4926 eq = memEQ(pv1, pv2, cur1);
4937 Compares the strings in two SVs. Returns -1, 0, or 1 indicating whether the
4938 string in C<sv1> is less than, equal to, or greater than the string in
4945 Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2)
4950 bool pv1tmp = FALSE;
4951 bool pv2tmp = FALSE;
4958 pv1 = SvPV(sv1, cur1);
4965 pv2 = SvPV(sv2, cur2);
4967 /* do not utf8ize the comparands as a side-effect */
4968 if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) {
4969 if (PL_hints & HINT_UTF8_DISTINCT)
4970 return SvUTF8(sv1) ? 1 : -1;
4973 pv2 = (char*)bytes_to_utf8((U8*)pv2, &cur2);
4977 pv1 = (char*)bytes_to_utf8((U8*)pv1, &cur1);
4983 cmp = cur2 ? -1 : 0;
4987 I32 retval = memcmp((void*)pv1, (void*)pv2, cur1 < cur2 ? cur1 : cur2);
4990 cmp = retval < 0 ? -1 : 1;
4991 } else if (cur1 == cur2) {
4994 cmp = cur1 < cur2 ? -1 : 1;
5007 =for apidoc sv_cmp_locale
5009 Compares the strings in two SVs in a locale-aware manner. See
5016 Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2)
5018 #ifdef USE_LOCALE_COLLATE
5024 if (PL_collation_standard)
5028 pv1 = sv1 ? sv_collxfrm(sv1, &len1) : (char *) NULL;
5030 pv2 = sv2 ? sv_collxfrm(sv2, &len2) : (char *) NULL;
5032 if (!pv1 || !len1) {
5043 retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2);
5046 return retval < 0 ? -1 : 1;
5049 * When the result of collation is equality, that doesn't mean
5050 * that there are no differences -- some locales exclude some
5051 * characters from consideration. So to avoid false equalities,
5052 * we use the raw string as a tiebreaker.
5058 #endif /* USE_LOCALE_COLLATE */
5060 return sv_cmp(sv1, sv2);
5063 #ifdef USE_LOCALE_COLLATE
5065 * Any scalar variable may carry PERL_MAGIC_collxfrm magic that contains the
5066 * scalar data of the variable transformed to such a format that
5067 * a normal memory comparison can be used to compare the data
5068 * according to the locale settings.
5071 Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp)
5075 mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL;
5076 if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) {
5081 Safefree(mg->mg_ptr);
5083 if ((xf = mem_collxfrm(s, len, &xlen))) {
5084 if (SvREADONLY(sv)) {
5087 return xf + sizeof(PL_collation_ix);
5090 sv_magic(sv, 0, PERL_MAGIC_collxfrm, 0, 0);
5091 mg = mg_find(sv, PERL_MAGIC_collxfrm);
5104 if (mg && mg->mg_ptr) {
5106 return mg->mg_ptr + sizeof(PL_collation_ix);
5114 #endif /* USE_LOCALE_COLLATE */
5119 Get a line from the filehandle and store it into the SV, optionally
5120 appending to the currently-stored string.
5126 Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append)
5130 register STDCHAR rslast;
5131 register STDCHAR *bp;
5135 SV_CHECK_THINKFIRST(sv);
5136 (void)SvUPGRADE(sv, SVt_PV);
5140 if (RsSNARF(PL_rs)) {
5144 else if (RsRECORD(PL_rs)) {
5145 I32 recsize, bytesread;
5148 /* Grab the size of the record we're getting */
5149 recsize = SvIV(SvRV(PL_rs));
5150 (void)SvPOK_only(sv); /* Validate pointer */
5151 buffer = SvGROW(sv, recsize + 1);
5154 /* VMS wants read instead of fread, because fread doesn't respect */
5155 /* RMS record boundaries. This is not necessarily a good thing to be */
5156 /* doing, but we've got no other real choice */
5157 bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize);
5159 bytesread = PerlIO_read(fp, buffer, recsize);
5161 SvCUR_set(sv, bytesread);
5162 buffer[bytesread] = '\0';
5163 if (PerlIO_isutf8(fp))
5167 return(SvCUR(sv) ? SvPVX(sv) : Nullch);
5169 else if (RsPARA(PL_rs)) {
5174 /* Get $/ i.e. PL_rs into same encoding as stream wants */
5175 if (PerlIO_isutf8(fp)) {
5176 rsptr = SvPVutf8(PL_rs, rslen);
5179 if (SvUTF8(PL_rs)) {
5180 if (!sv_utf8_downgrade(PL_rs, TRUE)) {
5181 Perl_croak(aTHX_ "Wide character in $/");
5184 rsptr = SvPV(PL_rs, rslen);
5188 rslast = rslen ? rsptr[rslen - 1] : '\0';
5190 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5191 do { /* to make sure file boundaries work right */
5194 i = PerlIO_getc(fp);
5198 PerlIO_ungetc(fp,i);
5204 /* See if we know enough about I/O mechanism to cheat it ! */
5206 /* This used to be #ifdef test - it is made run-time test for ease
5207 of abstracting out stdio interface. One call should be cheap
5208 enough here - and may even be a macro allowing compile
5212 if (PerlIO_fast_gets(fp)) {
5215 * We're going to steal some values from the stdio struct
5216 * and put EVERYTHING in the innermost loop into registers.
5218 register STDCHAR *ptr;
5222 #if defined(VMS) && defined(PERLIO_IS_STDIO)
5223 /* An ungetc()d char is handled separately from the regular
5224 * buffer, so we getc() it back out and stuff it in the buffer.
5226 i = PerlIO_getc(fp);
5227 if (i == EOF) return 0;
5228 *(--((*fp)->_ptr)) = (unsigned char) i;
5232 /* Here is some breathtakingly efficient cheating */
5234 cnt = PerlIO_get_cnt(fp); /* get count into register */
5235 (void)SvPOK_only(sv); /* validate pointer */
5236 if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */
5237 if (cnt > 80 && SvLEN(sv) > append) {
5238 shortbuffered = cnt - SvLEN(sv) + append + 1;
5239 cnt -= shortbuffered;
5243 /* remember that cnt can be negative */
5244 SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1)));
5249 bp = (STDCHAR*)SvPVX(sv) + append; /* move these two too to registers */
5250 ptr = (STDCHAR*)PerlIO_get_ptr(fp);
5251 DEBUG_P(PerlIO_printf(Perl_debug_log,
5252 "Screamer: entering, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5253 DEBUG_P(PerlIO_printf(Perl_debug_log,
5254 "Screamer: entering: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5255 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5256 PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0)));
5261 while (cnt > 0) { /* this | eat */
5263 if ((*bp++ = *ptr++) == rslast) /* really | dust */
5264 goto thats_all_folks; /* screams | sed :-) */
5268 Copy(ptr, bp, cnt, char); /* this | eat */
5269 bp += cnt; /* screams | dust */
5270 ptr += cnt; /* louder | sed :-) */
5275 if (shortbuffered) { /* oh well, must extend */
5276 cnt = shortbuffered;
5278 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5280 SvGROW(sv, SvLEN(sv) + append + cnt + 2);
5281 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5285 DEBUG_P(PerlIO_printf(Perl_debug_log,
5286 "Screamer: going to getc, ptr=%"UVuf", cnt=%ld\n",
5287 PTR2UV(ptr),(long)cnt));
5288 PerlIO_set_ptrcnt(fp, ptr, cnt); /* deregisterize cnt and ptr */
5289 DEBUG_P(PerlIO_printf(Perl_debug_log,
5290 "Screamer: pre: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5291 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5292 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5293 /* This used to call 'filbuf' in stdio form, but as that behaves like
5294 getc when cnt <= 0 we use PerlIO_getc here to avoid introducing
5295 another abstraction. */
5296 i = PerlIO_getc(fp); /* get more characters */
5297 DEBUG_P(PerlIO_printf(Perl_debug_log,
5298 "Screamer: post: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5299 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5300 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5301 cnt = PerlIO_get_cnt(fp);
5302 ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */
5303 DEBUG_P(PerlIO_printf(Perl_debug_log,
5304 "Screamer: after getc, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5306 if (i == EOF) /* all done for ever? */
5307 goto thats_really_all_folks;
5309 bpx = bp - (STDCHAR*)SvPVX(sv); /* box up before relocation */
5311 SvGROW(sv, bpx + cnt + 2);
5312 bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */
5314 *bp++ = i; /* store character from PerlIO_getc */
5316 if (rslen && (STDCHAR)i == rslast) /* all done for now? */
5317 goto thats_all_folks;
5321 if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) ||
5322 memNE((char*)bp - rslen, rsptr, rslen))
5323 goto screamer; /* go back to the fray */
5324 thats_really_all_folks:
5326 cnt += shortbuffered;
5327 DEBUG_P(PerlIO_printf(Perl_debug_log,
5328 "Screamer: quitting, ptr=%"UVuf", cnt=%ld\n",PTR2UV(ptr),(long)cnt));
5329 PerlIO_set_ptrcnt(fp, ptr, cnt); /* put these back or we're in trouble */
5330 DEBUG_P(PerlIO_printf(Perl_debug_log,
5331 "Screamer: end: FILE * thinks ptr=%"UVuf", cnt=%ld, base=%"UVuf"\n",
5332 PTR2UV(PerlIO_get_ptr(fp)), (long)PerlIO_get_cnt(fp),
5333 PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0)));
5335 SvCUR_set(sv, bp - (STDCHAR*)SvPVX(sv)); /* set length */
5336 DEBUG_P(PerlIO_printf(Perl_debug_log,
5337 "Screamer: done, len=%ld, string=|%.*s|\n",
5338 (long)SvCUR(sv),(int)SvCUR(sv),SvPVX(sv)));
5343 /*The big, slow, and stupid way */
5346 /* Need to work around EPOC SDK features */
5347 /* On WINS: MS VC5 generates calls to _chkstk, */
5348 /* if a `large' stack frame is allocated */
5349 /* gcc on MARM does not generate calls like these */
5355 register STDCHAR *bpe = buf + sizeof(buf);
5357 while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe)
5358 ; /* keep reading */
5362 cnt = PerlIO_read(fp,(char*)buf, sizeof(buf));
5363 /* Accomodate broken VAXC compiler, which applies U8 cast to
5364 * both args of ?: operator, causing EOF to change into 255
5366 if (cnt) { i = (U8)buf[cnt - 1]; } else { i = EOF; }
5370 sv_catpvn(sv, (char *) buf, cnt);
5372 sv_setpvn(sv, (char *) buf, cnt);
5374 if (i != EOF && /* joy */
5376 SvCUR(sv) < rslen ||
5377 memNE(SvPVX(sv) + SvCUR(sv) - rslen, rsptr, rslen)))
5381 * If we're reading from a TTY and we get a short read,
5382 * indicating that the user hit his EOF character, we need
5383 * to notice it now, because if we try to read from the TTY
5384 * again, the EOF condition will disappear.
5386 * The comparison of cnt to sizeof(buf) is an optimization
5387 * that prevents unnecessary calls to feof().
5391 if (!(cnt < sizeof(buf) && PerlIO_eof(fp)))
5396 if (RsPARA(PL_rs)) { /* have to do this both before and after */
5397 while (i != EOF) { /* to make sure file boundaries work right */
5398 i = PerlIO_getc(fp);
5400 PerlIO_ungetc(fp,i);
5406 if (PerlIO_isutf8(fp))
5411 return (SvCUR(sv) - append) ? SvPVX(sv) : Nullch;
5418 Auto-increment of the value in the SV.
5424 Perl_sv_inc(pTHX_ register SV *sv)
5433 if (SvTHINKFIRST(sv)) {
5434 if (SvREADONLY(sv)) {
5435 if (PL_curcop != &PL_compiling)
5436 Perl_croak(aTHX_ PL_no_modify);
5440 if (SvAMAGIC(sv) && AMG_CALLun(sv,inc))
5442 i = PTR2IV(SvRV(sv));
5447 flags = SvFLAGS(sv);
5448 if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) {
5449 /* It's (privately or publicly) a float, but not tested as an
5450 integer, so test it to see. */
5452 flags = SvFLAGS(sv);
5454 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5455 /* It's publicly an integer, or privately an integer-not-float */
5458 if (SvUVX(sv) == UV_MAX)
5459 sv_setnv(sv, (NV)UV_MAX + 1.0);
5461 (void)SvIOK_only_UV(sv);
5464 if (SvIVX(sv) == IV_MAX)
5465 sv_setuv(sv, (UV)IV_MAX + 1);
5467 (void)SvIOK_only(sv);
5473 if (flags & SVp_NOK) {
5474 (void)SvNOK_only(sv);
5479 if (!(flags & SVp_POK) || !*SvPVX(sv)) {
5480 if ((flags & SVTYPEMASK) < SVt_PVIV)
5481 sv_upgrade(sv, SVt_IV);
5482 (void)SvIOK_only(sv);
5487 while (isALPHA(*d)) d++;
5488 while (isDIGIT(*d)) d++;
5490 #ifdef PERL_PRESERVE_IVUV
5491 /* Got to punt this an an integer if needs be, but we don't issue
5492 warnings. Probably ought to make the sv_iv_please() that does
5493 the conversion if possible, and silently. */
5494 I32 numtype = looks_like_number(sv);
5495 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5496 /* Need to try really hard to see if it's an integer.
5497 9.22337203685478e+18 is an integer.
5498 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5499 so $a="9.22337203685478e+18"; $a+0; $a++
5500 needs to be the same as $a="9.22337203685478e+18"; $a++
5507 /* sv_2iv *should* have made this an NV */
5508 if (flags & SVp_NOK) {
5509 (void)SvNOK_only(sv);
5513 /* I don't think we can get here. Maybe I should assert this
5514 And if we do get here I suspect that sv_setnv will croak. NWC
5516 #if defined(USE_LONG_DOUBLE)
5517 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",
5518 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5520 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5521 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5524 #endif /* PERL_PRESERVE_IVUV */
5525 sv_setnv(sv,Atof(SvPVX(sv)) + 1.0);
5529 while (d >= SvPVX(sv)) {
5537 /* MKS: The original code here died if letters weren't consecutive.
5538 * at least it didn't have to worry about non-C locales. The
5539 * new code assumes that ('z'-'a')==('Z'-'A'), letters are
5540 * arranged in order (although not consecutively) and that only
5541 * [A-Za-z] are accepted by isALPHA in the C locale.
5543 if (*d != 'z' && *d != 'Z') {
5544 do { ++*d; } while (!isALPHA(*d));
5547 *(d--) -= 'z' - 'a';
5552 *(d--) -= 'z' - 'a' + 1;
5556 /* oh,oh, the number grew */
5557 SvGROW(sv, SvCUR(sv) + 2);
5559 for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX(sv); d--)
5570 Auto-decrement of the value in the SV.
5576 Perl_sv_dec(pTHX_ register SV *sv)
5584 if (SvTHINKFIRST(sv)) {
5585 if (SvREADONLY(sv)) {
5586 if (PL_curcop != &PL_compiling)
5587 Perl_croak(aTHX_ PL_no_modify);
5591 if (SvAMAGIC(sv) && AMG_CALLun(sv,dec))
5593 i = PTR2IV(SvRV(sv));
5598 /* Unlike sv_inc we don't have to worry about string-never-numbers
5599 and keeping them magic. But we mustn't warn on punting */
5600 flags = SvFLAGS(sv);
5601 if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) {
5602 /* It's publicly an integer, or privately an integer-not-float */
5605 if (SvUVX(sv) == 0) {
5606 (void)SvIOK_only(sv);
5610 (void)SvIOK_only_UV(sv);
5614 if (SvIVX(sv) == IV_MIN)
5615 sv_setnv(sv, (NV)IV_MIN - 1.0);
5617 (void)SvIOK_only(sv);
5623 if (flags & SVp_NOK) {
5625 (void)SvNOK_only(sv);
5628 if (!(flags & SVp_POK)) {
5629 if ((flags & SVTYPEMASK) < SVt_PVNV)
5630 sv_upgrade(sv, SVt_NV);
5632 (void)SvNOK_only(sv);
5635 #ifdef PERL_PRESERVE_IVUV
5637 I32 numtype = looks_like_number(sv);
5638 if (numtype && !(numtype & IS_NUMBER_INFINITY)) {
5639 /* Need to try really hard to see if it's an integer.
5640 9.22337203685478e+18 is an integer.
5641 but "9.22337203685478e+18" + 0 is UV=9223372036854779904
5642 so $a="9.22337203685478e+18"; $a+0; $a--
5643 needs to be the same as $a="9.22337203685478e+18"; $a--
5650 /* sv_2iv *should* have made this an NV */
5651 if (flags & SVp_NOK) {
5652 (void)SvNOK_only(sv);
5656 /* I don't think we can get here. Maybe I should assert this
5657 And if we do get here I suspect that sv_setnv will croak. NWC
5659 #if defined(USE_LONG_DOUBLE)
5660 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",
5661 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5663 DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%"UVxf" NV=%g\n",
5664 SvPVX(sv), SvIVX(sv), SvNVX(sv)));
5668 #endif /* PERL_PRESERVE_IVUV */
5669 sv_setnv(sv,Atof(SvPVX(sv)) - 1.0); /* punt */
5673 =for apidoc sv_mortalcopy
5675 Creates a new SV which is a copy of the original SV. The new SV is marked
5681 /* Make a string that will exist for the duration of the expression
5682 * evaluation. Actually, it may have to last longer than that, but
5683 * hopefully we won't free it until it has been assigned to a
5684 * permanent location. */
5687 Perl_sv_mortalcopy(pTHX_ SV *oldstr)
5692 sv_setsv(sv,oldstr);
5694 PL_tmps_stack[++PL_tmps_ix] = sv;
5700 =for apidoc sv_newmortal
5702 Creates a new SV which is mortal. The reference count of the SV is set to 1.
5708 Perl_sv_newmortal(pTHX)
5713 SvFLAGS(sv) = SVs_TEMP;
5715 PL_tmps_stack[++PL_tmps_ix] = sv;
5720 =for apidoc sv_2mortal
5722 Marks an SV as mortal. The SV will be destroyed when the current context
5728 /* same thing without the copying */
5731 Perl_sv_2mortal(pTHX_ register SV *sv)
5735 if (SvREADONLY(sv) && SvIMMORTAL(sv))
5738 PL_tmps_stack[++PL_tmps_ix] = sv;
5746 Creates a new SV and copies a string into it. The reference count for the
5747 SV is set to 1. If C<len> is zero, Perl will compute the length using
5748 strlen(). For efficiency, consider using C<newSVpvn> instead.
5754 Perl_newSVpv(pTHX_ const char *s, STRLEN len)
5761 sv_setpvn(sv,s,len);
5766 =for apidoc newSVpvn
5768 Creates a new SV and copies a string into it. The reference count for the
5769 SV is set to 1. Note that if C<len> is zero, Perl will create a zero length
5770 string. You are responsible for ensuring that the source string is at least
5777 Perl_newSVpvn(pTHX_ const char *s, STRLEN len)
5782 sv_setpvn(sv,s,len);
5787 =for apidoc newSVpvn_share
5789 Creates a new SV and populates it with a string from
5790 the string table. Turns on READONLY and FAKE.
5791 The idea here is that as string table is used for shared hash
5792 keys these strings will have SvPVX == HeKEY and hash lookup
5793 will avoid string compare.
5799 Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash)
5802 bool is_utf8 = FALSE;
5807 if (is_utf8 && !(PL_hints & HINT_UTF8_DISTINCT)) {
5808 STRLEN tmplen = len;
5809 /* See the note in hv.c:hv_fetch() --jhi */
5810 src = (char*)bytes_from_utf8((U8*)src, &tmplen, &is_utf8);
5814 PERL_HASH(hash, src, len);
5816 sv_upgrade(sv, SVt_PVIV);
5817 SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash);
5829 #if defined(PERL_IMPLICIT_CONTEXT)
5831 Perl_newSVpvf_nocontext(const char* pat, ...)
5836 va_start(args, pat);
5837 sv = vnewSVpvf(pat, &args);
5844 =for apidoc newSVpvf
5846 Creates a new SV an initialize it with the string formatted like
5853 Perl_newSVpvf(pTHX_ const char* pat, ...)
5857 va_start(args, pat);
5858 sv = vnewSVpvf(pat, &args);
5864 Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args)
5868 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
5875 Creates a new SV and copies a floating point value into it.
5876 The reference count for the SV is set to 1.
5882 Perl_newSVnv(pTHX_ NV n)
5894 Creates a new SV and copies an integer into it. The reference count for the
5901 Perl_newSViv(pTHX_ IV i)
5913 Creates a new SV and copies an unsigned integer into it.
5914 The reference count for the SV is set to 1.
5920 Perl_newSVuv(pTHX_ UV u)
5930 =for apidoc newRV_noinc
5932 Creates an RV wrapper for an SV. The reference count for the original
5933 SV is B<not> incremented.
5939 Perl_newRV_noinc(pTHX_ SV *tmpRef)
5944 sv_upgrade(sv, SVt_RV);
5951 /* newRV_inc is #defined to newRV in sv.h */
5953 Perl_newRV(pTHX_ SV *tmpRef)
5955 return newRV_noinc(SvREFCNT_inc(tmpRef));
5961 Creates a new SV which is an exact duplicate of the original SV.
5966 /* make an exact duplicate of old */
5969 Perl_newSVsv(pTHX_ register SV *old)
5975 if (SvTYPE(old) == SVTYPEMASK) {
5976 if (ckWARN_d(WARN_INTERNAL))
5977 Perl_warner(aTHX_ WARN_INTERNAL, "semi-panic: attempt to dup freed string");
5992 Perl_sv_reset(pTHX_ register char *s, HV *stash)
6000 char todo[PERL_UCHAR_MAX+1];
6005 if (!*s) { /* reset ?? searches */
6006 for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
6007 pm->op_pmdynflags &= ~PMdf_USED;
6012 /* reset variables */
6014 if (!HvARRAY(stash))
6017 Zero(todo, 256, char);
6019 i = (unsigned char)*s;
6023 max = (unsigned char)*s++;
6024 for ( ; i <= max; i++) {
6027 for (i = 0; i <= (I32) HvMAX(stash); i++) {
6028 for (entry = HvARRAY(stash)[i];
6030 entry = HeNEXT(entry))
6032 if (!todo[(U8)*HeKEY(entry)])
6034 gv = (GV*)HeVAL(entry);
6036 if (SvTHINKFIRST(sv)) {
6037 if (!SvREADONLY(sv) && SvROK(sv))
6042 if (SvTYPE(sv) >= SVt_PV) {
6044 if (SvPVX(sv) != Nullch)
6051 if (GvHV(gv) && !HvNAME(GvHV(gv))) {
6053 #ifdef USE_ENVIRON_ARRAY
6055 environ[0] = Nullch;
6064 Perl_sv_2io(pTHX_ SV *sv)
6070 switch (SvTYPE(sv)) {
6078 Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv));
6082 Perl_croak(aTHX_ PL_no_usym, "filehandle");
6084 return sv_2io(SvRV(sv));
6085 gv = gv_fetchpv(SvPV(sv,n_a), FALSE, SVt_PVIO);
6091 Perl_croak(aTHX_ "Bad filehandle: %s", SvPV(sv,n_a));
6098 Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref)
6105 return *gvp = Nullgv, Nullcv;
6106 switch (SvTYPE(sv)) {
6125 SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */
6126 tryAMAGICunDEREF(to_cv);
6129 if (SvTYPE(sv) == SVt_PVCV) {
6138 Perl_croak(aTHX_ "Not a subroutine reference");
6143 gv = gv_fetchpv(SvPV(sv, n_a), lref, SVt_PVCV);
6149 if (lref && !GvCVu(gv)) {
6152 tmpsv = NEWSV(704,0);
6153 gv_efullname3(tmpsv, gv, Nullch);
6154 /* XXX this is probably not what they think they're getting.
6155 * It has the same effect as "sub name;", i.e. just a forward
6157 newSUB(start_subparse(FALSE, 0),
6158 newSVOP(OP_CONST, 0, tmpsv),
6163 Perl_croak(aTHX_ "Unable to create sub named \"%s\"", SvPV(sv,n_a));
6172 Returns true if the SV has a true value by Perl's rules.
6178 Perl_sv_true(pTHX_ register SV *sv)
6184 if ((tXpv = (XPV*)SvANY(sv)) &&
6185 (tXpv->xpv_cur > 1 ||
6186 (tXpv->xpv_cur && *tXpv->xpv_pv != '0')))
6193 return SvIVX(sv) != 0;
6196 return SvNVX(sv) != 0.0;
6198 return sv_2bool(sv);
6204 Perl_sv_iv(pTHX_ register SV *sv)
6208 return (IV)SvUVX(sv);
6215 Perl_sv_uv(pTHX_ register SV *sv)
6220 return (UV)SvIVX(sv);
6226 Perl_sv_nv(pTHX_ register SV *sv)
6234 Perl_sv_pv(pTHX_ SV *sv)
6241 return sv_2pv(sv, &n_a);
6245 Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp)
6251 return sv_2pv(sv, lp);
6255 =for apidoc sv_pvn_force
6257 Get a sensible string out of the SV somehow.
6263 Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp)
6265 return sv_pvn_force_flags(sv, lp, SV_GMAGIC);
6269 =for apidoc sv_pvn_force_flags
6271 Get a sensible string out of the SV somehow.
6272 If C<flags> has C<SV_GMAGIC> bit set, will C<mg_get> on C<sv> if
6273 appropriate, else not. C<sv_pvn_force> and C<sv_pvn_force_nomg> are
6274 implemented in terms of this function.
6280 Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags)
6284 if (SvTHINKFIRST(sv) && !SvROK(sv))
6285 sv_force_normal(sv);
6291 if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) {
6292 Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0),
6293 PL_op_name[PL_op->op_type]);
6296 s = sv_2pv_flags(sv, lp, flags);
6297 if (s != SvPVX(sv)) { /* Almost, but not quite, sv_setpvn() */
6302 (void)SvUPGRADE(sv, SVt_PV); /* Never FALSE */
6303 SvGROW(sv, len + 1);
6304 Move(s,SvPVX(sv),len,char);
6309 SvPOK_on(sv); /* validate pointer */
6311 DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" 2pv(%s)\n",
6312 PTR2UV(sv),SvPVX(sv)));
6319 Perl_sv_pvbyte(pTHX_ SV *sv)
6321 sv_utf8_downgrade(sv,0);
6326 Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp)
6328 sv_utf8_downgrade(sv,0);
6329 return sv_pvn(sv,lp);
6333 Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp)
6335 sv_utf8_downgrade(sv,0);
6336 return sv_pvn_force(sv,lp);
6340 Perl_sv_pvutf8(pTHX_ SV *sv)
6342 sv_utf8_upgrade(sv);
6347 Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp)
6349 sv_utf8_upgrade(sv);
6350 return sv_pvn(sv,lp);
6354 =for apidoc sv_pvutf8n_force
6356 Get a sensible UTF8-encoded string out of the SV somehow. See
6363 Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp)
6365 sv_utf8_upgrade(sv);
6366 return sv_pvn_force(sv,lp);
6370 =for apidoc sv_reftype
6372 Returns a string describing what the SV is a reference to.
6378 Perl_sv_reftype(pTHX_ SV *sv, int ob)
6380 if (ob && SvOBJECT(sv))
6381 return HvNAME(SvSTASH(sv));
6383 switch (SvTYPE(sv)) {
6397 case SVt_PVLV: return "LVALUE";
6398 case SVt_PVAV: return "ARRAY";
6399 case SVt_PVHV: return "HASH";
6400 case SVt_PVCV: return "CODE";
6401 case SVt_PVGV: return "GLOB";
6402 case SVt_PVFM: return "FORMAT";
6403 case SVt_PVIO: return "IO";
6404 default: return "UNKNOWN";
6410 =for apidoc sv_isobject
6412 Returns a boolean indicating whether the SV is an RV pointing to a blessed
6413 object. If the SV is not an RV, or if the object is not blessed, then this
6420 Perl_sv_isobject(pTHX_ SV *sv)
6437 Returns a boolean indicating whether the SV is blessed into the specified
6438 class. This does not check for subtypes; use C<sv_derived_from> to verify
6439 an inheritance relationship.
6445 Perl_sv_isa(pTHX_ SV *sv, const char *name)
6457 return strEQ(HvNAME(SvSTASH(sv)), name);
6463 Creates a new SV for the RV, C<rv>, to point to. If C<rv> is not an RV then
6464 it will be upgraded to one. If C<classname> is non-null then the new SV will
6465 be blessed in the specified package. The new SV is returned and its
6466 reference count is 1.
6472 Perl_newSVrv(pTHX_ SV *rv, const char *classname)
6478 SV_CHECK_THINKFIRST(rv);
6481 if (SvTYPE(rv) >= SVt_PVMG) {
6482 U32 refcnt = SvREFCNT(rv);
6486 SvREFCNT(rv) = refcnt;
6489 if (SvTYPE(rv) < SVt_RV)
6490 sv_upgrade(rv, SVt_RV);
6491 else if (SvTYPE(rv) > SVt_RV) {
6492 (void)SvOOK_off(rv);
6493 if (SvPVX(rv) && SvLEN(rv))
6494 Safefree(SvPVX(rv));
6504 HV* stash = gv_stashpv(classname, TRUE);
6505 (void)sv_bless(rv, stash);
6511 =for apidoc sv_setref_pv
6513 Copies a pointer into a new SV, optionally blessing the SV. The C<rv>
6514 argument will be upgraded to an RV. That RV will be modified to point to
6515 the new SV. If the C<pv> argument is NULL then C<PL_sv_undef> will be placed
6516 into the SV. The C<classname> argument indicates the package for the
6517 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6518 will be returned and will have a reference count of 1.
6520 Do not use with other Perl types such as HV, AV, SV, CV, because those
6521 objects will become corrupted by the pointer copy process.
6523 Note that C<sv_setref_pvn> copies the string while this copies the pointer.
6529 Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv)
6532 sv_setsv(rv, &PL_sv_undef);
6536 sv_setiv(newSVrv(rv,classname), PTR2IV(pv));
6541 =for apidoc sv_setref_iv
6543 Copies an integer into a new SV, optionally blessing the SV. The C<rv>
6544 argument will be upgraded to an RV. That RV will be modified to point to
6545 the new SV. The C<classname> argument indicates the package for the
6546 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6547 will be returned and will have a reference count of 1.
6553 Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv)
6555 sv_setiv(newSVrv(rv,classname), iv);
6560 =for apidoc sv_setref_uv
6562 Copies an unsigned integer into a new SV, optionally blessing the SV. The C<rv>
6563 argument will be upgraded to an RV. That RV will be modified to point to
6564 the new SV. The C<classname> argument indicates the package for the
6565 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6566 will be returned and will have a reference count of 1.
6572 Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv)
6574 sv_setuv(newSVrv(rv,classname), uv);
6579 =for apidoc sv_setref_nv
6581 Copies a double into a new SV, optionally blessing the SV. The C<rv>
6582 argument will be upgraded to an RV. That RV will be modified to point to
6583 the new SV. The C<classname> argument indicates the package for the
6584 blessing. Set C<classname> to C<Nullch> to avoid the blessing. The new SV
6585 will be returned and will have a reference count of 1.
6591 Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv)
6593 sv_setnv(newSVrv(rv,classname), nv);
6598 =for apidoc sv_setref_pvn
6600 Copies a string into a new SV, optionally blessing the SV. The length of the
6601 string must be specified with C<n>. The C<rv> argument will be upgraded to
6602 an RV. That RV will be modified to point to the new SV. The C<classname>
6603 argument indicates the package for the blessing. Set C<classname> to
6604 C<Nullch> to avoid the blessing. The new SV will be returned and will have
6605 a reference count of 1.
6607 Note that C<sv_setref_pv> copies the pointer while this copies the string.
6613 Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, char *pv, STRLEN n)
6615 sv_setpvn(newSVrv(rv,classname), pv, n);
6620 =for apidoc sv_bless
6622 Blesses an SV into a specified package. The SV must be an RV. The package
6623 must be designated by its stash (see C<gv_stashpv()>). The reference count
6624 of the SV is unaffected.
6630 Perl_sv_bless(pTHX_ SV *sv, HV *stash)
6634 Perl_croak(aTHX_ "Can't bless non-reference value");
6636 if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) {
6637 if (SvREADONLY(tmpRef))
6638 Perl_croak(aTHX_ PL_no_modify);
6639 if (SvOBJECT(tmpRef)) {
6640 if (SvTYPE(tmpRef) != SVt_PVIO)
6642 SvREFCNT_dec(SvSTASH(tmpRef));
6645 SvOBJECT_on(tmpRef);
6646 if (SvTYPE(tmpRef) != SVt_PVIO)
6648 (void)SvUPGRADE(tmpRef, SVt_PVMG);
6649 SvSTASH(tmpRef) = (HV*)SvREFCNT_inc(stash);
6660 S_sv_unglob(pTHX_ SV *sv)
6664 assert(SvTYPE(sv) == SVt_PVGV);
6669 SvREFCNT_dec(GvSTASH(sv));
6670 GvSTASH(sv) = Nullhv;
6672 sv_unmagic(sv, PERL_MAGIC_glob);
6673 Safefree(GvNAME(sv));
6676 /* need to keep SvANY(sv) in the right arena */
6677 xpvmg = new_XPVMG();
6678 StructCopy(SvANY(sv), xpvmg, XPVMG);
6679 del_XPVGV(SvANY(sv));
6682 SvFLAGS(sv) &= ~SVTYPEMASK;
6683 SvFLAGS(sv) |= SVt_PVMG;
6687 =for apidoc sv_unref_flags
6689 Unsets the RV status of the SV, and decrements the reference count of
6690 whatever was being referenced by the RV. This can almost be thought of
6691 as a reversal of C<newSVrv>. The C<cflags> argument can contain
6692 C<SV_IMMEDIATE_UNREF> to force the reference count to be decremented
6693 (otherwise the decrementing is conditional on the reference count being
6694 different from one or the reference being a readonly SV).
6701 Perl_sv_unref_flags(pTHX_ SV *sv, U32 flags)
6705 if (SvWEAKREF(sv)) {
6713 if (SvREFCNT(rv) != 1 || SvREADONLY(rv) || flags) /* SV_IMMEDIATE_UNREF */
6715 else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */
6716 sv_2mortal(rv); /* Schedule for freeing later */
6720 =for apidoc sv_unref
6722 Unsets the RV status of the SV, and decrements the reference count of
6723 whatever was being referenced by the RV. This can almost be thought of
6724 as a reversal of C<newSVrv>. This is C<sv_unref_flags> with the C<flag>
6725 being zero. See C<SvROK_off>.
6731 Perl_sv_unref(pTHX_ SV *sv)
6733 sv_unref_flags(sv, 0);
6737 Perl_sv_taint(pTHX_ SV *sv)
6739 sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0);
6743 Perl_sv_untaint(pTHX_ SV *sv)
6745 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6746 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6753 Perl_sv_tainted(pTHX_ SV *sv)
6755 if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) {
6756 MAGIC *mg = mg_find(sv, PERL_MAGIC_taint);
6757 if (mg && ((mg->mg_len & 1) || ((mg->mg_len & 2) && mg->mg_obj == sv)))
6764 =for apidoc sv_setpviv
6766 Copies an integer into the given SV, also updating its string value.
6767 Does not handle 'set' magic. See C<sv_setpviv_mg>.
6773 Perl_sv_setpviv(pTHX_ SV *sv, IV iv)
6775 char buf[TYPE_CHARS(UV)];
6777 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6779 sv_setpvn(sv, ptr, ebuf - ptr);
6784 =for apidoc sv_setpviv_mg
6786 Like C<sv_setpviv>, but also handles 'set' magic.
6792 Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv)
6794 char buf[TYPE_CHARS(UV)];
6796 char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf);
6798 sv_setpvn(sv, ptr, ebuf - ptr);
6802 #if defined(PERL_IMPLICIT_CONTEXT)
6804 Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...)
6808 va_start(args, pat);
6809 sv_vsetpvf(sv, pat, &args);
6815 Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...)
6819 va_start(args, pat);
6820 sv_vsetpvf_mg(sv, pat, &args);
6826 =for apidoc sv_setpvf
6828 Processes its arguments like C<sprintf> and sets an SV to the formatted
6829 output. Does not handle 'set' magic. See C<sv_setpvf_mg>.
6835 Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...)
6838 va_start(args, pat);
6839 sv_vsetpvf(sv, pat, &args);
6844 Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6846 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6850 =for apidoc sv_setpvf_mg
6852 Like C<sv_setpvf>, but also handles 'set' magic.
6858 Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6861 va_start(args, pat);
6862 sv_vsetpvf_mg(sv, pat, &args);
6867 Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6869 sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6873 #if defined(PERL_IMPLICIT_CONTEXT)
6875 Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...)
6879 va_start(args, pat);
6880 sv_vcatpvf(sv, pat, &args);
6885 Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...)
6889 va_start(args, pat);
6890 sv_vcatpvf_mg(sv, pat, &args);
6896 =for apidoc sv_catpvf
6898 Processes its arguments like C<sprintf> and appends the formatted
6899 output to an SV. If the appended data contains "wide" characters
6900 (including, but not limited to, SVs with a UTF-8 PV formatted with %s,
6901 and characters >255 formatted with %c), the original SV might get
6902 upgraded to UTF-8. Handles 'get' magic, but not 'set' magic.
6903 C<SvSETMAGIC()> must typically be called after calling this function
6904 to handle 'set' magic.
6909 Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...)
6912 va_start(args, pat);
6913 sv_vcatpvf(sv, pat, &args);
6918 Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args)
6920 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6924 =for apidoc sv_catpvf_mg
6926 Like C<sv_catpvf>, but also handles 'set' magic.
6932 Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...)
6935 va_start(args, pat);
6936 sv_vcatpvf_mg(sv, pat, &args);
6941 Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args)
6943 sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
6948 =for apidoc sv_vsetpvfn
6950 Works like C<vcatpvfn> but copies the text into the SV instead of
6957 Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6959 sv_setpvn(sv, "", 0);
6960 sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted);
6964 S_expect_number(pTHX_ char** pattern)
6967 switch (**pattern) {
6968 case '1': case '2': case '3':
6969 case '4': case '5': case '6':
6970 case '7': case '8': case '9':
6971 while (isDIGIT(**pattern))
6972 var = var * 10 + (*(*pattern)++ - '0');
6976 #define EXPECT_NUMBER(pattern, var) (var = S_expect_number(aTHX_ &pattern))
6979 =for apidoc sv_vcatpvfn
6981 Processes its arguments like C<vsprintf> and appends the formatted output
6982 to an SV. Uses an array of SVs if the C style variable argument list is
6983 missing (NULL). When running with taint checks enabled, indicates via
6984 C<maybe_tainted> if results are untrustworthy (often due to the use of
6991 Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted)
6998 static char nullstr[] = "(null)";
7001 /* no matter what, this is a string now */
7002 (void)SvPV_force(sv, origlen);
7004 /* special-case "", "%s", and "%_" */
7007 if (patlen == 2 && pat[0] == '%') {
7011 char *s = va_arg(*args, char*);
7012 sv_catpv(sv, s ? s : nullstr);
7014 else if (svix < svmax) {
7015 sv_catsv(sv, *svargs);
7016 if (DO_UTF8(*svargs))
7022 argsv = va_arg(*args, SV*);
7023 sv_catsv(sv, argsv);
7028 /* See comment on '_' below */
7033 patend = (char*)pat + patlen;
7034 for (p = (char*)pat; p < patend; p = q) {
7037 bool vectorize = FALSE;
7038 bool vectorarg = FALSE;
7039 bool vec_utf = FALSE;
7045 bool has_precis = FALSE;
7047 bool is_utf = FALSE;
7050 U8 utf8buf[UTF8_MAXLEN+1];
7051 STRLEN esignlen = 0;
7053 char *eptr = Nullch;
7055 /* Times 4: a decimal digit takes more than 3 binary digits.
7056 * NV_DIG: mantissa takes than many decimal digits.
7057 * Plus 32: Playing safe. */
7058 char ebuf[IV_DIG * 4 + NV_DIG + 32];
7059 /* large enough for "%#.#f" --chip */
7060 /* what about long double NVs? --jhi */
7063 U8 *vecstr = Null(U8*);
7075 STRLEN dotstrlen = 1;
7076 I32 efix = 0; /* explicit format parameter index */
7077 I32 ewix = 0; /* explicit width index */
7078 I32 epix = 0; /* explicit precision index */
7079 I32 evix = 0; /* explicit vector index */
7080 bool asterisk = FALSE;
7082 /* echo everything up to the next format specification */
7083 for (q = p; q < patend && *q != '%'; ++q) ;
7085 sv_catpvn(sv, p, q - p);
7092 We allow format specification elements in this order:
7093 \d+\$ explicit format parameter index
7095 \*?(\d+\$)?v vector with optional (optionally specified) arg
7096 \d+|\*(\d+\$)? width using optional (optionally specified) arg
7097 \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg
7099 [%bcdefginopsux_DFOUX] format (mandatory)
7101 if (EXPECT_NUMBER(q, width)) {
7142 if (EXPECT_NUMBER(q, ewix))
7151 if ((vectorarg = asterisk)) {
7161 EXPECT_NUMBER(q, width);
7166 vecsv = va_arg(*args, SV*);
7168 vecsv = (evix ? evix <= svmax : svix < svmax) ?
7169 svargs[ewix ? ewix-1 : svix++] : &PL_sv_undef;
7170 dotstr = SvPVx(vecsv, dotstrlen);
7175 vecsv = va_arg(*args, SV*);
7176 vecstr = (U8*)SvPVx(vecsv,veclen);
7177 vec_utf = DO_UTF8(vecsv);
7179 else if (efix ? efix <= svmax : svix < svmax) {
7180 vecsv = svargs[efix ? efix-1 : svix++];
7181 vecstr = (U8*)SvPVx(vecsv,veclen);
7182 vec_utf = DO_UTF8(vecsv);
7192 i = va_arg(*args, int);
7194 i = (ewix ? ewix <= svmax : svix < svmax) ?
7195 SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7197 width = (i < 0) ? -i : i;
7207 if (EXPECT_NUMBER(q, epix) && *q++ != '$')
7210 i = va_arg(*args, int);
7212 i = (ewix ? ewix <= svmax : svix < svmax)
7213 ? SvIVx(svargs[ewix ? ewix-1 : svix++]) : 0;
7214 precis = (i < 0) ? 0 : i;
7219 precis = precis * 10 + (*q++ - '0');
7227 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7238 #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE))
7239 if (*(q + 1) == 'l') { /* lld, llf */
7262 argsv = (efix ? efix <= svmax : svix < svmax) ?
7263 svargs[efix ? efix-1 : svix++] : &PL_sv_undef;
7270 uv = args ? va_arg(*args, int) : SvIVx(argsv);
7272 (!UNI_IS_INVARIANT(uv) && SvUTF8(sv)))
7274 eptr = (char*)utf8buf;
7275 elen = uvchr_to_utf8((U8*)eptr, uv) - utf8buf;
7287 eptr = va_arg(*args, char*);
7289 #ifdef MACOS_TRADITIONAL
7290 /* On MacOS, %#s format is used for Pascal strings */
7295 elen = strlen(eptr);
7298 elen = sizeof nullstr - 1;
7302 eptr = SvPVx(argsv, elen);
7303 if (DO_UTF8(argsv)) {
7304 if (has_precis && precis < elen) {
7306 sv_pos_u2b(argsv, &p, 0); /* sticks at end */
7309 if (width) { /* fudge width (can't fudge elen) */
7310 width += elen - sv_len_utf8(argsv);
7319 * The "%_" hack might have to be changed someday,
7320 * if ISO or ANSI decide to use '_' for something.
7321 * So we keep it hidden from users' code.
7325 argsv = va_arg(*args, SV*);
7326 eptr = SvPVx(argsv, elen);
7332 if (has_precis && elen > precis)
7341 uv = PTR2UV(args ? va_arg(*args, void*) : argsv);
7359 iv = (IV)utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7369 case 'h': iv = (short)va_arg(*args, int); break;
7370 default: iv = va_arg(*args, int); break;
7371 case 'l': iv = va_arg(*args, long); break;
7372 case 'V': iv = va_arg(*args, IV); break;
7374 case 'q': iv = va_arg(*args, Quad_t); break;
7381 case 'h': iv = (short)iv; break;
7383 case 'l': iv = (long)iv; break;
7386 case 'q': iv = (Quad_t)iv; break;
7393 esignbuf[esignlen++] = plus;
7397 esignbuf[esignlen++] = '-';
7439 uv = utf8n_to_uvchr(vecstr, veclen, &ulen, 0);
7449 case 'h': uv = (unsigned short)va_arg(*args, unsigned); break;
7450 default: uv = va_arg(*args, unsigned); break;
7451 case 'l': uv = va_arg(*args, unsigned long); break;
7452 case 'V': uv = va_arg(*args, UV); break;
7454 case 'q': uv = va_arg(*args, Quad_t); break;
7461 case 'h': uv = (unsigned short)uv; break;
7463 case 'l': uv = (unsigned long)uv; break;
7466 case 'q': uv = (Quad_t)uv; break;
7472 eptr = ebuf + sizeof ebuf;
7478 p = (char*)((c == 'X')
7479 ? "0123456789ABCDEF" : "0123456789abcdef");
7485 esignbuf[esignlen++] = '0';
7486 esignbuf[esignlen++] = c; /* 'x' or 'X' */
7492 *--eptr = '0' + dig;
7494 if (alt && *eptr != '0')
7500 *--eptr = '0' + dig;
7503 esignbuf[esignlen++] = '0';
7504 esignbuf[esignlen++] = 'b';
7507 default: /* it had better be ten or less */
7508 #if defined(PERL_Y2KWARN)
7509 if (ckWARN(WARN_Y2K)) {
7511 char *s = SvPV(sv,n);
7512 if (n >= 2 && s[n-2] == '1' && s[n-1] == '9'
7513 && (n == 2 || !isDIGIT(s[n-3])))
7515 Perl_warner(aTHX_ WARN_Y2K,
7516 "Possible Y2K bug: %%%c %s",
7517 c, "format string following '19'");
7523 *--eptr = '0' + dig;
7524 } while (uv /= base);
7527 elen = (ebuf + sizeof ebuf) - eptr;
7530 zeros = precis - elen;
7531 else if (precis == 0 && elen == 1 && *eptr == '0')
7536 /* FLOATING POINT */
7539 c = 'f'; /* maybe %F isn't supported here */
7545 /* This is evil, but floating point is even more evil */
7548 nv = args ? va_arg(*args, NV) : SvNVx(argsv);
7551 if (c != 'e' && c != 'E') {
7553 (void)Perl_frexp(nv, &i);
7554 if (i == PERL_INT_MIN)
7555 Perl_die(aTHX_ "panic: frexp");
7557 need = BIT_DIGITS(i);
7559 need += has_precis ? precis : 6; /* known default */
7563 need += 20; /* fudge factor */
7564 if (PL_efloatsize < need) {
7565 Safefree(PL_efloatbuf);
7566 PL_efloatsize = need + 20; /* more fudge */
7567 New(906, PL_efloatbuf, PL_efloatsize, char);
7568 PL_efloatbuf[0] = '\0';
7571 eptr = ebuf + sizeof ebuf;
7574 #if defined(USE_LONG_DOUBLE) && defined(PERL_PRIfldbl)
7576 /* Copy the one or more characters in a long double
7577 * format before the 'base' ([efgEFG]) character to
7578 * the format string. */
7579 static char const prifldbl[] = PERL_PRIfldbl;
7580 char const *p = prifldbl + sizeof(prifldbl) - 3;
7581 while (p >= prifldbl) { *--eptr = *p--; }
7586 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7591 do { *--eptr = '0' + (base % 10); } while (base /= 10);
7603 /* No taint. Otherwise we are in the strange situation
7604 * where printf() taints but print($float) doesn't.
7606 (void)sprintf(PL_efloatbuf, eptr, nv);
7608 eptr = PL_efloatbuf;
7609 elen = strlen(PL_efloatbuf);
7616 i = SvCUR(sv) - origlen;
7619 case 'h': *(va_arg(*args, short*)) = i; break;
7620 default: *(va_arg(*args, int*)) = i; break;
7621 case 'l': *(va_arg(*args, long*)) = i; break;
7622 case 'V': *(va_arg(*args, IV*)) = i; break;
7624 case 'q': *(va_arg(*args, Quad_t*)) = i; break;
7629 sv_setuv_mg(argsv, (UV)i);
7630 continue; /* not "break" */
7637 if (!args && ckWARN(WARN_PRINTF) &&
7638 (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) {
7639 SV *msg = sv_newmortal();
7640 Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ",
7641 (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf");
7644 Perl_sv_catpvf(aTHX_ msg,
7645 "\"%%%c\"", c & 0xFF);
7647 Perl_sv_catpvf(aTHX_ msg,
7648 "\"%%\\%03"UVof"\"",
7651 sv_catpv(msg, "end of string");
7652 Perl_warner(aTHX_ WARN_PRINTF, "%"SVf, msg); /* yes, this is reentrant */
7655 /* output mangled stuff ... */
7661 /* ... right here, because formatting flags should not apply */
7662 SvGROW(sv, SvCUR(sv) + elen + 1);
7664 Copy(eptr, p, elen, char);
7667 SvCUR(sv) = p - SvPVX(sv);
7668 continue; /* not "break" */
7671 have = esignlen + zeros + elen;
7672 need = (have > width ? have : width);
7675 SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1);
7677 if (esignlen && fill == '0') {
7678 for (i = 0; i < esignlen; i++)
7682 memset(p, fill, gap);
7685 if (esignlen && fill != '0') {
7686 for (i = 0; i < esignlen; i++)
7690 for (i = zeros; i; i--)
7694 Copy(eptr, p, elen, char);
7698 memset(p, ' ', gap);
7703 Copy(dotstr, p, dotstrlen, char);
7707 vectorize = FALSE; /* done iterating over vecstr */
7712 SvCUR(sv) = p - SvPVX(sv);
7720 #if defined(USE_ITHREADS)
7722 #if defined(USE_THREADS)
7723 # include "error: USE_THREADS and USE_ITHREADS are incompatible"
7726 #ifndef GpREFCNT_inc
7727 # define GpREFCNT_inc(gp) ((gp) ? (++(gp)->gp_refcnt, (gp)) : (GP*)NULL)
7731 #define sv_dup_inc(s) SvREFCNT_inc(sv_dup(s))
7732 #define av_dup(s) (AV*)sv_dup((SV*)s)
7733 #define av_dup_inc(s) (AV*)SvREFCNT_inc(sv_dup((SV*)s))
7734 #define hv_dup(s) (HV*)sv_dup((SV*)s)
7735 #define hv_dup_inc(s) (HV*)SvREFCNT_inc(sv_dup((SV*)s))
7736 #define cv_dup(s) (CV*)sv_dup((SV*)s)
7737 #define cv_dup_inc(s) (CV*)SvREFCNT_inc(sv_dup((SV*)s))
7738 #define io_dup(s) (IO*)sv_dup((SV*)s)
7739 #define io_dup_inc(s) (IO*)SvREFCNT_inc(sv_dup((SV*)s))
7740 #define gv_dup(s) (GV*)sv_dup((SV*)s)
7741 #define gv_dup_inc(s) (GV*)SvREFCNT_inc(sv_dup((SV*)s))
7742 #define SAVEPV(p) (p ? savepv(p) : Nullch)
7743 #define SAVEPVN(p,n) (p ? savepvn(p,n) : Nullch)
7746 Perl_re_dup(pTHX_ REGEXP *r)
7748 /* XXX fix when pmop->op_pmregexp becomes shared */
7749 return ReREFCNT_inc(r);
7753 Perl_fp_dup(pTHX_ PerlIO *fp, char type)
7757 return (PerlIO*)NULL;
7759 /* look for it in the table first */
7760 ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp);
7764 /* create anew and remember what it is */
7765 ret = PerlIO_fdupopen(aTHX_ fp);
7766 ptr_table_store(PL_ptr_table, fp, ret);
7771 Perl_dirp_dup(pTHX_ DIR *dp)
7780 Perl_gp_dup(pTHX_ GP *gp)
7785 /* look for it in the table first */
7786 ret = (GP*)ptr_table_fetch(PL_ptr_table, gp);
7790 /* create anew and remember what it is */
7791 Newz(0, ret, 1, GP);
7792 ptr_table_store(PL_ptr_table, gp, ret);
7795 ret->gp_refcnt = 0; /* must be before any other dups! */
7796 ret->gp_sv = sv_dup_inc(gp->gp_sv);
7797 ret->gp_io = io_dup_inc(gp->gp_io);
7798 ret->gp_form = cv_dup_inc(gp->gp_form);
7799 ret->gp_av = av_dup_inc(gp->gp_av);
7800 ret->gp_hv = hv_dup_inc(gp->gp_hv);
7801 ret->gp_egv = gv_dup(gp->gp_egv); /* GvEGV is not refcounted */
7802 ret->gp_cv = cv_dup_inc(gp->gp_cv);
7803 ret->gp_cvgen = gp->gp_cvgen;
7804 ret->gp_flags = gp->gp_flags;
7805 ret->gp_line = gp->gp_line;
7806 ret->gp_file = gp->gp_file; /* points to COP.cop_file */
7811 Perl_mg_dup(pTHX_ MAGIC *mg)
7813 MAGIC *mgprev = (MAGIC*)NULL;
7816 return (MAGIC*)NULL;
7817 /* look for it in the table first */
7818 mgret = (MAGIC*)ptr_table_fetch(PL_ptr_table, mg);
7822 for (; mg; mg = mg->mg_moremagic) {
7824 Newz(0, nmg, 1, MAGIC);
7826 mgprev->mg_moremagic = nmg;
7829 nmg->mg_virtual = mg->mg_virtual; /* XXX copy dynamic vtable? */
7830 nmg->mg_private = mg->mg_private;
7831 nmg->mg_type = mg->mg_type;
7832 nmg->mg_flags = mg->mg_flags;
7833 if (mg->mg_type == PERL_MAGIC_qr) {
7834 nmg->mg_obj = (SV*)re_dup((REGEXP*)mg->mg_obj);
7837 nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED)
7838 ? sv_dup_inc(mg->mg_obj)
7839 : sv_dup(mg->mg_obj);
7841 nmg->mg_len = mg->mg_len;
7842 nmg->mg_ptr = mg->mg_ptr; /* XXX random ptr? */
7843 if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) {
7844 if (mg->mg_len >= 0) {
7845 nmg->mg_ptr = SAVEPVN(mg->mg_ptr, mg->mg_len);
7846 if (mg->mg_type == PERL_MAGIC_overload_table &&
7847 AMT_AMAGIC((AMT*)mg->mg_ptr))
7849 AMT *amtp = (AMT*)mg->mg_ptr;
7850 AMT *namtp = (AMT*)nmg->mg_ptr;
7852 for (i = 1; i < NofAMmeth; i++) {
7853 namtp->table[i] = cv_dup_inc(amtp->table[i]);
7857 else if (mg->mg_len == HEf_SVKEY)
7858 nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr);
7866 Perl_ptr_table_new(pTHX)
7869 Newz(0, tbl, 1, PTR_TBL_t);
7872 Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*);
7877 Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, void *sv)
7879 PTR_TBL_ENT_t *tblent;
7880 UV hash = PTR2UV(sv);
7882 tblent = tbl->tbl_ary[hash & tbl->tbl_max];
7883 for (; tblent; tblent = tblent->next) {
7884 if (tblent->oldval == sv)
7885 return tblent->newval;
7891 Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, void *oldv, void *newv)
7893 PTR_TBL_ENT_t *tblent, **otblent;
7894 /* XXX this may be pessimal on platforms where pointers aren't good
7895 * hash values e.g. if they grow faster in the most significant
7897 UV hash = PTR2UV(oldv);
7901 otblent = &tbl->tbl_ary[hash & tbl->tbl_max];
7902 for (tblent = *otblent; tblent; i=0, tblent = tblent->next) {
7903 if (tblent->oldval == oldv) {
7904 tblent->newval = newv;
7909 Newz(0, tblent, 1, PTR_TBL_ENT_t);
7910 tblent->oldval = oldv;
7911 tblent->newval = newv;
7912 tblent->next = *otblent;
7915 if (i && tbl->tbl_items > tbl->tbl_max)
7916 ptr_table_split(tbl);
7920 Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl)
7922 PTR_TBL_ENT_t **ary = tbl->tbl_ary;
7923 UV oldsize = tbl->tbl_max + 1;
7924 UV newsize = oldsize * 2;
7927 Renew(ary, newsize, PTR_TBL_ENT_t*);
7928 Zero(&ary[oldsize], newsize-oldsize, PTR_TBL_ENT_t*);
7929 tbl->tbl_max = --newsize;
7931 for (i=0; i < oldsize; i++, ary++) {
7932 PTR_TBL_ENT_t **curentp, **entp, *ent;
7935 curentp = ary + oldsize;
7936 for (entp = ary, ent = *ary; ent; ent = *entp) {
7937 if ((newsize & PTR2UV(ent->oldval)) != i) {
7939 ent->next = *curentp;
7950 Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl)
7952 register PTR_TBL_ENT_t **array;
7953 register PTR_TBL_ENT_t *entry;
7954 register PTR_TBL_ENT_t *oentry = Null(PTR_TBL_ENT_t*);
7958 if (!tbl || !tbl->tbl_items) {
7962 array = tbl->tbl_ary;
7969 entry = entry->next;
7973 if (++riter > max) {
7976 entry = array[riter];
7984 Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl)
7989 ptr_table_clear(tbl);
7990 Safefree(tbl->tbl_ary);
7999 S_gv_share(pTHX_ SV *sstr)
8002 SV *sv = &PL_sv_no; /* just need SvREADONLY-ness */
8004 if (GvIO(gv) || GvFORM(gv)) {
8005 GvSHARED_off(gv); /* GvIOs cannot be shared. nor can GvFORMs */
8007 else if (!GvCV(gv)) {
8011 /* CvPADLISTs cannot be shared */
8012 if (!CvXSUB(GvCV(gv))) {
8017 if (!GvSHARED(gv)) {
8019 PerlIO_printf(Perl_debug_log, "gv_share: unable to share %s::%s\n",
8020 HvNAME(GvSTASH(gv)), GvNAME(gv));
8026 * write attempts will die with
8027 * "Modification of a read-only value attempted"
8033 SvREADONLY_on(GvSV(gv));
8040 SvREADONLY_on(GvAV(gv));
8047 SvREADONLY_on(GvAV(gv));
8050 return sstr; /* he_dup() will SvREFCNT_inc() */
8054 Perl_sv_dup(pTHX_ SV *sstr)
8058 if (!sstr || SvTYPE(sstr) == SVTYPEMASK)
8060 /* look for it in the table first */
8061 dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr);
8065 /* create anew and remember what it is */
8067 ptr_table_store(PL_ptr_table, sstr, dstr);
8070 SvFLAGS(dstr) = SvFLAGS(sstr);
8071 SvFLAGS(dstr) &= ~SVf_OOK; /* don't propagate OOK hack */
8072 SvREFCNT(dstr) = 0; /* must be before any other dups! */
8075 if (SvANY(sstr) && PL_watch_pvx && SvPVX(sstr) == PL_watch_pvx)
8076 PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n",
8077 PL_watch_pvx, SvPVX(sstr));
8080 switch (SvTYPE(sstr)) {
8085 SvANY(dstr) = new_XIV();
8086 SvIVX(dstr) = SvIVX(sstr);
8089 SvANY(dstr) = new_XNV();
8090 SvNVX(dstr) = SvNVX(sstr);
8093 SvANY(dstr) = new_XRV();
8094 SvRV(dstr) = SvRV(sstr) && SvWEAKREF(SvRV(sstr))
8095 ? sv_dup(SvRV(sstr))
8096 : sv_dup_inc(SvRV(sstr));
8099 SvANY(dstr) = new_XPV();
8100 SvCUR(dstr) = SvCUR(sstr);
8101 SvLEN(dstr) = SvLEN(sstr);
8103 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8104 ? sv_dup(SvRV(sstr))
8105 : sv_dup_inc(SvRV(sstr));
8106 else if (SvPVX(sstr) && SvLEN(sstr))
8107 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8109 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8112 SvANY(dstr) = new_XPVIV();
8113 SvCUR(dstr) = SvCUR(sstr);
8114 SvLEN(dstr) = SvLEN(sstr);
8115 SvIVX(dstr) = SvIVX(sstr);
8117 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8118 ? sv_dup(SvRV(sstr))
8119 : sv_dup_inc(SvRV(sstr));
8120 else if (SvPVX(sstr) && SvLEN(sstr))
8121 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8123 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8126 SvANY(dstr) = new_XPVNV();
8127 SvCUR(dstr) = SvCUR(sstr);
8128 SvLEN(dstr) = SvLEN(sstr);
8129 SvIVX(dstr) = SvIVX(sstr);
8130 SvNVX(dstr) = SvNVX(sstr);
8132 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8133 ? sv_dup(SvRV(sstr))
8134 : sv_dup_inc(SvRV(sstr));
8135 else if (SvPVX(sstr) && SvLEN(sstr))
8136 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8138 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8141 SvANY(dstr) = new_XPVMG();
8142 SvCUR(dstr) = SvCUR(sstr);
8143 SvLEN(dstr) = SvLEN(sstr);
8144 SvIVX(dstr) = SvIVX(sstr);
8145 SvNVX(dstr) = SvNVX(sstr);
8146 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8147 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8149 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8150 ? sv_dup(SvRV(sstr))
8151 : sv_dup_inc(SvRV(sstr));
8152 else if (SvPVX(sstr) && SvLEN(sstr))
8153 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8155 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8158 SvANY(dstr) = new_XPVBM();
8159 SvCUR(dstr) = SvCUR(sstr);
8160 SvLEN(dstr) = SvLEN(sstr);
8161 SvIVX(dstr) = SvIVX(sstr);
8162 SvNVX(dstr) = SvNVX(sstr);
8163 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8164 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8166 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8167 ? sv_dup(SvRV(sstr))
8168 : sv_dup_inc(SvRV(sstr));
8169 else if (SvPVX(sstr) && SvLEN(sstr))
8170 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8172 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8173 BmRARE(dstr) = BmRARE(sstr);
8174 BmUSEFUL(dstr) = BmUSEFUL(sstr);
8175 BmPREVIOUS(dstr)= BmPREVIOUS(sstr);
8178 SvANY(dstr) = new_XPVLV();
8179 SvCUR(dstr) = SvCUR(sstr);
8180 SvLEN(dstr) = SvLEN(sstr);
8181 SvIVX(dstr) = SvIVX(sstr);
8182 SvNVX(dstr) = SvNVX(sstr);
8183 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8184 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8186 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8187 ? sv_dup(SvRV(sstr))
8188 : sv_dup_inc(SvRV(sstr));
8189 else if (SvPVX(sstr) && SvLEN(sstr))
8190 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8192 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8193 LvTARGOFF(dstr) = LvTARGOFF(sstr); /* XXX sometimes holds PMOP* when DEBUGGING */
8194 LvTARGLEN(dstr) = LvTARGLEN(sstr);
8195 LvTARG(dstr) = sv_dup_inc(LvTARG(sstr));
8196 LvTYPE(dstr) = LvTYPE(sstr);
8199 if (GvSHARED((GV*)sstr)) {
8201 if ((share = gv_share(sstr))) {
8205 PerlIO_printf(Perl_debug_log, "sv_dup: sharing %s::%s\n",
8206 HvNAME(GvSTASH(share)), GvNAME(share));
8211 SvANY(dstr) = new_XPVGV();
8212 SvCUR(dstr) = SvCUR(sstr);
8213 SvLEN(dstr) = SvLEN(sstr);
8214 SvIVX(dstr) = SvIVX(sstr);
8215 SvNVX(dstr) = SvNVX(sstr);
8216 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8217 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8219 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8220 ? sv_dup(SvRV(sstr))
8221 : sv_dup_inc(SvRV(sstr));
8222 else if (SvPVX(sstr) && SvLEN(sstr))
8223 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8225 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8226 GvNAMELEN(dstr) = GvNAMELEN(sstr);
8227 GvNAME(dstr) = SAVEPVN(GvNAME(sstr), GvNAMELEN(sstr));
8228 GvSTASH(dstr) = hv_dup_inc(GvSTASH(sstr));
8229 GvFLAGS(dstr) = GvFLAGS(sstr);
8230 GvGP(dstr) = gp_dup(GvGP(sstr));
8231 (void)GpREFCNT_inc(GvGP(dstr));
8234 SvANY(dstr) = new_XPVIO();
8235 SvCUR(dstr) = SvCUR(sstr);
8236 SvLEN(dstr) = SvLEN(sstr);
8237 SvIVX(dstr) = SvIVX(sstr);
8238 SvNVX(dstr) = SvNVX(sstr);
8239 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8240 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8242 SvRV(dstr) = SvWEAKREF(SvRV(sstr))
8243 ? sv_dup(SvRV(sstr))
8244 : sv_dup_inc(SvRV(sstr));
8245 else if (SvPVX(sstr) && SvLEN(sstr))
8246 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8248 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8249 IoIFP(dstr) = fp_dup(IoIFP(sstr), IoTYPE(sstr));
8250 if (IoOFP(sstr) == IoIFP(sstr))
8251 IoOFP(dstr) = IoIFP(dstr);
8253 IoOFP(dstr) = fp_dup(IoOFP(sstr), IoTYPE(sstr));
8254 /* PL_rsfp_filters entries have fake IoDIRP() */
8255 if (IoDIRP(sstr) && !(IoFLAGS(sstr) & IOf_FAKE_DIRP))
8256 IoDIRP(dstr) = dirp_dup(IoDIRP(sstr));
8258 IoDIRP(dstr) = IoDIRP(sstr);
8259 IoLINES(dstr) = IoLINES(sstr);
8260 IoPAGE(dstr) = IoPAGE(sstr);
8261 IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr);
8262 IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr);
8263 IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr));
8264 IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr));
8265 IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr));
8266 IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr));
8267 IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr));
8268 IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr));
8269 IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr);
8270 IoTYPE(dstr) = IoTYPE(sstr);
8271 IoFLAGS(dstr) = IoFLAGS(sstr);
8274 SvANY(dstr) = new_XPVAV();
8275 SvCUR(dstr) = SvCUR(sstr);
8276 SvLEN(dstr) = SvLEN(sstr);
8277 SvIVX(dstr) = SvIVX(sstr);
8278 SvNVX(dstr) = SvNVX(sstr);
8279 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8280 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8281 AvARYLEN((AV*)dstr) = sv_dup_inc(AvARYLEN((AV*)sstr));
8282 AvFLAGS((AV*)dstr) = AvFLAGS((AV*)sstr);
8283 if (AvARRAY((AV*)sstr)) {
8284 SV **dst_ary, **src_ary;
8285 SSize_t items = AvFILLp((AV*)sstr) + 1;
8287 src_ary = AvARRAY((AV*)sstr);
8288 Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*);
8289 ptr_table_store(PL_ptr_table, src_ary, dst_ary);
8290 SvPVX(dstr) = (char*)dst_ary;
8291 AvALLOC((AV*)dstr) = dst_ary;
8292 if (AvREAL((AV*)sstr)) {
8294 *dst_ary++ = sv_dup_inc(*src_ary++);
8298 *dst_ary++ = sv_dup(*src_ary++);
8300 items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr);
8301 while (items-- > 0) {
8302 *dst_ary++ = &PL_sv_undef;
8306 SvPVX(dstr) = Nullch;
8307 AvALLOC((AV*)dstr) = (SV**)NULL;
8311 SvANY(dstr) = new_XPVHV();
8312 SvCUR(dstr) = SvCUR(sstr);
8313 SvLEN(dstr) = SvLEN(sstr);
8314 SvIVX(dstr) = SvIVX(sstr);
8315 SvNVX(dstr) = SvNVX(sstr);
8316 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8317 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8318 HvRITER((HV*)dstr) = HvRITER((HV*)sstr);
8319 if (HvARRAY((HV*)sstr)) {
8321 XPVHV *dxhv = (XPVHV*)SvANY(dstr);
8322 XPVHV *sxhv = (XPVHV*)SvANY(sstr);
8323 Newz(0, dxhv->xhv_array,
8324 PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char);
8325 while (i <= sxhv->xhv_max) {
8326 ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i],
8327 !!HvSHAREKEYS(sstr));
8330 dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr));
8333 SvPVX(dstr) = Nullch;
8334 HvEITER((HV*)dstr) = (HE*)NULL;
8336 HvPMROOT((HV*)dstr) = HvPMROOT((HV*)sstr); /* XXX */
8337 HvNAME((HV*)dstr) = SAVEPV(HvNAME((HV*)sstr));
8340 SvANY(dstr) = new_XPVFM();
8341 FmLINES(dstr) = FmLINES(sstr);
8345 SvANY(dstr) = new_XPVCV();
8347 SvCUR(dstr) = SvCUR(sstr);
8348 SvLEN(dstr) = SvLEN(sstr);
8349 SvIVX(dstr) = SvIVX(sstr);
8350 SvNVX(dstr) = SvNVX(sstr);
8351 SvMAGIC(dstr) = mg_dup(SvMAGIC(sstr));
8352 SvSTASH(dstr) = hv_dup_inc(SvSTASH(sstr));
8353 if (SvPVX(sstr) && SvLEN(sstr))
8354 SvPVX(dstr) = SAVEPVN(SvPVX(sstr), SvLEN(sstr)-1);
8356 SvPVX(dstr) = SvPVX(sstr); /* XXX shared string/random ptr? */
8357 CvSTASH(dstr) = hv_dup(CvSTASH(sstr));/* NOTE: not refcounted */
8358 CvSTART(dstr) = CvSTART(sstr);
8359 CvROOT(dstr) = OpREFCNT_inc(CvROOT(sstr));
8360 CvXSUB(dstr) = CvXSUB(sstr);
8361 CvXSUBANY(dstr) = CvXSUBANY(sstr);
8362 CvGV(dstr) = gv_dup(CvGV(sstr));
8363 CvDEPTH(dstr) = CvDEPTH(sstr);
8364 if (CvPADLIST(sstr) && !AvREAL(CvPADLIST(sstr))) {
8365 /* XXX padlists are real, but pretend to be not */
8366 AvREAL_on(CvPADLIST(sstr));
8367 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8368 AvREAL_off(CvPADLIST(sstr));
8369 AvREAL_off(CvPADLIST(dstr));
8372 CvPADLIST(dstr) = av_dup_inc(CvPADLIST(sstr));
8373 if (!CvANON(sstr) || CvCLONED(sstr))
8374 CvOUTSIDE(dstr) = cv_dup_inc(CvOUTSIDE(sstr));
8376 CvOUTSIDE(dstr) = cv_dup(CvOUTSIDE(sstr));
8377 CvFLAGS(dstr) = CvFLAGS(sstr);
8380 Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr));
8384 if (SvOBJECT(dstr) && SvTYPE(dstr) != SVt_PVIO)
8391 Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max)
8396 return (PERL_CONTEXT*)NULL;
8398 /* look for it in the table first */
8399 ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs);
8403 /* create anew and remember what it is */
8404 Newz(56, ncxs, max + 1, PERL_CONTEXT);
8405 ptr_table_store(PL_ptr_table, cxs, ncxs);
8408 PERL_CONTEXT *cx = &cxs[ix];
8409 PERL_CONTEXT *ncx = &ncxs[ix];
8410 ncx->cx_type = cx->cx_type;
8411 if (CxTYPE(cx) == CXt_SUBST) {
8412 Perl_croak(aTHX_ "Cloning substitution context is unimplemented");
8415 ncx->blk_oldsp = cx->blk_oldsp;
8416 ncx->blk_oldcop = cx->blk_oldcop;
8417 ncx->blk_oldretsp = cx->blk_oldretsp;
8418 ncx->blk_oldmarksp = cx->blk_oldmarksp;
8419 ncx->blk_oldscopesp = cx->blk_oldscopesp;
8420 ncx->blk_oldpm = cx->blk_oldpm;
8421 ncx->blk_gimme = cx->blk_gimme;
8422 switch (CxTYPE(cx)) {
8424 ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0
8425 ? cv_dup_inc(cx->blk_sub.cv)
8426 : cv_dup(cx->blk_sub.cv));
8427 ncx->blk_sub.argarray = (cx->blk_sub.hasargs
8428 ? av_dup_inc(cx->blk_sub.argarray)
8430 ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray);
8431 ncx->blk_sub.olddepth = cx->blk_sub.olddepth;
8432 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8433 ncx->blk_sub.lval = cx->blk_sub.lval;
8436 ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval;
8437 ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type;
8438 ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv);
8439 ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root;
8440 ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text);
8443 ncx->blk_loop.label = cx->blk_loop.label;
8444 ncx->blk_loop.resetsp = cx->blk_loop.resetsp;
8445 ncx->blk_loop.redo_op = cx->blk_loop.redo_op;
8446 ncx->blk_loop.next_op = cx->blk_loop.next_op;
8447 ncx->blk_loop.last_op = cx->blk_loop.last_op;
8448 ncx->blk_loop.iterdata = (CxPADLOOP(cx)
8449 ? cx->blk_loop.iterdata
8450 : gv_dup((GV*)cx->blk_loop.iterdata));
8451 ncx->blk_loop.oldcurpad
8452 = (SV**)ptr_table_fetch(PL_ptr_table,
8453 cx->blk_loop.oldcurpad);
8454 ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave);
8455 ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval);
8456 ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary);
8457 ncx->blk_loop.iterix = cx->blk_loop.iterix;
8458 ncx->blk_loop.itermax = cx->blk_loop.itermax;
8461 ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv);
8462 ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv);
8463 ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv);
8464 ncx->blk_sub.hasargs = cx->blk_sub.hasargs;
8477 Perl_si_dup(pTHX_ PERL_SI *si)
8482 return (PERL_SI*)NULL;
8484 /* look for it in the table first */
8485 nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si);
8489 /* create anew and remember what it is */
8490 Newz(56, nsi, 1, PERL_SI);
8491 ptr_table_store(PL_ptr_table, si, nsi);
8493 nsi->si_stack = av_dup_inc(si->si_stack);
8494 nsi->si_cxix = si->si_cxix;
8495 nsi->si_cxmax = si->si_cxmax;
8496 nsi->si_cxstack = cx_dup(si->si_cxstack, si->si_cxix, si->si_cxmax);
8497 nsi->si_type = si->si_type;
8498 nsi->si_prev = si_dup(si->si_prev);
8499 nsi->si_next = si_dup(si->si_next);
8500 nsi->si_markoff = si->si_markoff;
8505 #define POPINT(ss,ix) ((ss)[--(ix)].any_i32)
8506 #define TOPINT(ss,ix) ((ss)[ix].any_i32)
8507 #define POPLONG(ss,ix) ((ss)[--(ix)].any_long)
8508 #define TOPLONG(ss,ix) ((ss)[ix].any_long)
8509 #define POPIV(ss,ix) ((ss)[--(ix)].any_iv)
8510 #define TOPIV(ss,ix) ((ss)[ix].any_iv)
8511 #define POPPTR(ss,ix) ((ss)[--(ix)].any_ptr)
8512 #define TOPPTR(ss,ix) ((ss)[ix].any_ptr)
8513 #define POPDPTR(ss,ix) ((ss)[--(ix)].any_dptr)
8514 #define TOPDPTR(ss,ix) ((ss)[ix].any_dptr)
8515 #define POPDXPTR(ss,ix) ((ss)[--(ix)].any_dxptr)
8516 #define TOPDXPTR(ss,ix) ((ss)[ix].any_dxptr)
8519 #define pv_dup_inc(p) SAVEPV(p)
8520 #define pv_dup(p) SAVEPV(p)
8521 #define svp_dup_inc(p,pp) any_dup(p,pp)
8524 Perl_any_dup(pTHX_ void *v, PerlInterpreter *proto_perl)
8531 /* look for it in the table first */
8532 ret = ptr_table_fetch(PL_ptr_table, v);
8536 /* see if it is part of the interpreter structure */
8537 if (v >= (void*)proto_perl && v < (void*)(proto_perl+1))
8538 ret = (void*)(((char*)aTHXo) + (((char*)v) - (char*)proto_perl));
8546 Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl)
8548 ANY *ss = proto_perl->Tsavestack;
8549 I32 ix = proto_perl->Tsavestack_ix;
8550 I32 max = proto_perl->Tsavestack_max;
8563 void (*dptr) (void*);
8564 void (*dxptr) (pTHXo_ void*);
8567 Newz(54, nss, max, ANY);
8573 case SAVEt_ITEM: /* normal string */
8574 sv = (SV*)POPPTR(ss,ix);
8575 TOPPTR(nss,ix) = sv_dup_inc(sv);
8576 sv = (SV*)POPPTR(ss,ix);
8577 TOPPTR(nss,ix) = sv_dup_inc(sv);
8579 case SAVEt_SV: /* scalar reference */
8580 sv = (SV*)POPPTR(ss,ix);
8581 TOPPTR(nss,ix) = sv_dup_inc(sv);
8582 gv = (GV*)POPPTR(ss,ix);
8583 TOPPTR(nss,ix) = gv_dup_inc(gv);
8585 case SAVEt_GENERIC_PVREF: /* generic char* */
8586 c = (char*)POPPTR(ss,ix);
8587 TOPPTR(nss,ix) = pv_dup(c);
8588 ptr = POPPTR(ss,ix);
8589 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8591 case SAVEt_GENERIC_SVREF: /* generic sv */
8592 case SAVEt_SVREF: /* scalar reference */
8593 sv = (SV*)POPPTR(ss,ix);
8594 TOPPTR(nss,ix) = sv_dup_inc(sv);
8595 ptr = POPPTR(ss,ix);
8596 TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */
8598 case SAVEt_AV: /* array reference */
8599 av = (AV*)POPPTR(ss,ix);
8600 TOPPTR(nss,ix) = av_dup_inc(av);
8601 gv = (GV*)POPPTR(ss,ix);
8602 TOPPTR(nss,ix) = gv_dup(gv);
8604 case SAVEt_HV: /* hash reference */
8605 hv = (HV*)POPPTR(ss,ix);
8606 TOPPTR(nss,ix) = hv_dup_inc(hv);
8607 gv = (GV*)POPPTR(ss,ix);
8608 TOPPTR(nss,ix) = gv_dup(gv);
8610 case SAVEt_INT: /* int reference */
8611 ptr = POPPTR(ss,ix);
8612 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8613 intval = (int)POPINT(ss,ix);
8614 TOPINT(nss,ix) = intval;
8616 case SAVEt_LONG: /* long reference */
8617 ptr = POPPTR(ss,ix);
8618 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8619 longval = (long)POPLONG(ss,ix);
8620 TOPLONG(nss,ix) = longval;
8622 case SAVEt_I32: /* I32 reference */
8623 case SAVEt_I16: /* I16 reference */
8624 case SAVEt_I8: /* I8 reference */
8625 ptr = POPPTR(ss,ix);
8626 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8630 case SAVEt_IV: /* IV reference */
8631 ptr = POPPTR(ss,ix);
8632 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8636 case SAVEt_SPTR: /* SV* reference */
8637 ptr = POPPTR(ss,ix);
8638 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8639 sv = (SV*)POPPTR(ss,ix);
8640 TOPPTR(nss,ix) = sv_dup(sv);
8642 case SAVEt_VPTR: /* random* reference */
8643 ptr = POPPTR(ss,ix);
8644 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8645 ptr = POPPTR(ss,ix);
8646 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8648 case SAVEt_PPTR: /* char* reference */
8649 ptr = POPPTR(ss,ix);
8650 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8651 c = (char*)POPPTR(ss,ix);
8652 TOPPTR(nss,ix) = pv_dup(c);
8654 case SAVEt_HPTR: /* HV* reference */
8655 ptr = POPPTR(ss,ix);
8656 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8657 hv = (HV*)POPPTR(ss,ix);
8658 TOPPTR(nss,ix) = hv_dup(hv);
8660 case SAVEt_APTR: /* AV* reference */
8661 ptr = POPPTR(ss,ix);
8662 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8663 av = (AV*)POPPTR(ss,ix);
8664 TOPPTR(nss,ix) = av_dup(av);
8667 gv = (GV*)POPPTR(ss,ix);
8668 TOPPTR(nss,ix) = gv_dup(gv);
8670 case SAVEt_GP: /* scalar reference */
8671 gp = (GP*)POPPTR(ss,ix);
8672 TOPPTR(nss,ix) = gp = gp_dup(gp);
8673 (void)GpREFCNT_inc(gp);
8674 gv = (GV*)POPPTR(ss,ix);
8675 TOPPTR(nss,ix) = gv_dup_inc(c);
8676 c = (char*)POPPTR(ss,ix);
8677 TOPPTR(nss,ix) = pv_dup(c);
8684 case SAVEt_MORTALIZESV:
8685 sv = (SV*)POPPTR(ss,ix);
8686 TOPPTR(nss,ix) = sv_dup_inc(sv);
8689 ptr = POPPTR(ss,ix);
8690 if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) {
8691 /* these are assumed to be refcounted properly */
8692 switch (((OP*)ptr)->op_type) {
8699 TOPPTR(nss,ix) = ptr;
8704 TOPPTR(nss,ix) = Nullop;
8709 TOPPTR(nss,ix) = Nullop;
8712 c = (char*)POPPTR(ss,ix);
8713 TOPPTR(nss,ix) = pv_dup_inc(c);
8716 longval = POPLONG(ss,ix);
8717 TOPLONG(nss,ix) = longval;
8720 hv = (HV*)POPPTR(ss,ix);
8721 TOPPTR(nss,ix) = hv_dup_inc(hv);
8722 c = (char*)POPPTR(ss,ix);
8723 TOPPTR(nss,ix) = pv_dup_inc(c);
8727 case SAVEt_DESTRUCTOR:
8728 ptr = POPPTR(ss,ix);
8729 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8730 dptr = POPDPTR(ss,ix);
8731 TOPDPTR(nss,ix) = (void (*)(void*))any_dup((void *)dptr, proto_perl);
8733 case SAVEt_DESTRUCTOR_X:
8734 ptr = POPPTR(ss,ix);
8735 TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */
8736 dxptr = POPDXPTR(ss,ix);
8737 TOPDXPTR(nss,ix) = (void (*)(pTHXo_ void*))any_dup((void *)dxptr, proto_perl);
8739 case SAVEt_REGCONTEXT:
8745 case SAVEt_STACK_POS: /* Position on Perl stack */
8749 case SAVEt_AELEM: /* array element */
8750 sv = (SV*)POPPTR(ss,ix);
8751 TOPPTR(nss,ix) = sv_dup_inc(sv);
8754 av = (AV*)POPPTR(ss,ix);
8755 TOPPTR(nss,ix) = av_dup_inc(av);
8757 case SAVEt_HELEM: /* hash element */
8758 sv = (SV*)POPPTR(ss,ix);
8759 TOPPTR(nss,ix) = sv_dup_inc(sv);
8760 sv = (SV*)POPPTR(ss,ix);
8761 TOPPTR(nss,ix) = sv_dup_inc(sv);
8762 hv = (HV*)POPPTR(ss,ix);
8763 TOPPTR(nss,ix) = hv_dup_inc(hv);
8766 ptr = POPPTR(ss,ix);
8767 TOPPTR(nss,ix) = ptr;
8774 av = (AV*)POPPTR(ss,ix);
8775 TOPPTR(nss,ix) = av_dup(av);
8778 longval = (long)POPLONG(ss,ix);
8779 TOPLONG(nss,ix) = longval;
8780 ptr = POPPTR(ss,ix);
8781 TOPPTR(nss,ix) = any_dup(ptr, proto_perl);
8782 sv = (SV*)POPPTR(ss,ix);
8783 TOPPTR(nss,ix) = sv_dup(sv);
8786 Perl_croak(aTHX_ "panic: ss_dup inconsistency");
8798 perl_clone(PerlInterpreter *proto_perl, UV flags)
8801 CPerlObj *pPerl = (CPerlObj*)proto_perl;
8804 #ifdef PERL_IMPLICIT_SYS
8805 return perl_clone_using(proto_perl, flags,
8807 proto_perl->IMemShared,
8808 proto_perl->IMemParse,
8818 perl_clone_using(PerlInterpreter *proto_perl, UV flags,
8819 struct IPerlMem* ipM, struct IPerlMem* ipMS,
8820 struct IPerlMem* ipMP, struct IPerlEnv* ipE,
8821 struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO,
8822 struct IPerlDir* ipD, struct IPerlSock* ipS,
8823 struct IPerlProc* ipP)
8825 /* XXX many of the string copies here can be optimized if they're
8826 * constants; they need to be allocated as common memory and just
8827 * their pointers copied. */
8831 CPerlObj *pPerl = new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO,
8833 PERL_SET_THX(pPerl);
8834 # else /* !PERL_OBJECT */
8835 PerlInterpreter *my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
8836 PERL_SET_THX(my_perl);
8839 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8845 # else /* !DEBUGGING */
8846 Zero(my_perl, 1, PerlInterpreter);
8847 # endif /* DEBUGGING */
8851 PL_MemShared = ipMS;
8859 # endif /* PERL_OBJECT */
8860 #else /* !PERL_IMPLICIT_SYS */
8862 PerlInterpreter *my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
8863 PERL_SET_THX(my_perl);
8866 memset(my_perl, 0xab, sizeof(PerlInterpreter));
8872 # else /* !DEBUGGING */
8873 Zero(my_perl, 1, PerlInterpreter);
8874 # endif /* DEBUGGING */
8875 #endif /* PERL_IMPLICIT_SYS */
8878 PL_xiv_arenaroot = NULL;
8880 PL_xnv_arenaroot = NULL;
8882 PL_xrv_arenaroot = NULL;
8884 PL_xpv_arenaroot = NULL;
8886 PL_xpviv_arenaroot = NULL;
8887 PL_xpviv_root = NULL;
8888 PL_xpvnv_arenaroot = NULL;
8889 PL_xpvnv_root = NULL;
8890 PL_xpvcv_arenaroot = NULL;
8891 PL_xpvcv_root = NULL;
8892 PL_xpvav_arenaroot = NULL;
8893 PL_xpvav_root = NULL;
8894 PL_xpvhv_arenaroot = NULL;
8895 PL_xpvhv_root = NULL;
8896 PL_xpvmg_arenaroot = NULL;
8897 PL_xpvmg_root = NULL;
8898 PL_xpvlv_arenaroot = NULL;
8899 PL_xpvlv_root = NULL;
8900 PL_xpvbm_arenaroot = NULL;
8901 PL_xpvbm_root = NULL;
8902 PL_he_arenaroot = NULL;
8904 PL_nice_chunk = NULL;
8905 PL_nice_chunk_size = 0;
8908 PL_sv_root = Nullsv;
8909 PL_sv_arenaroot = Nullsv;
8911 PL_debug = proto_perl->Idebug;
8913 /* create SV map for pointer relocation */
8914 PL_ptr_table = ptr_table_new();
8916 /* initialize these special pointers as early as possible */
8917 SvANY(&PL_sv_undef) = NULL;
8918 SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
8919 SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVt_NULL;
8920 ptr_table_store(PL_ptr_table, &proto_perl->Isv_undef, &PL_sv_undef);
8923 SvUPGRADE(&PL_sv_no, SVt_PVNV);
8925 SvANY(&PL_sv_no) = new_XPVNV();
8927 SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
8928 SvFLAGS(&PL_sv_no) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8929 SvPVX(&PL_sv_no) = SAVEPVN(PL_No, 0);
8930 SvCUR(&PL_sv_no) = 0;
8931 SvLEN(&PL_sv_no) = 1;
8932 SvNVX(&PL_sv_no) = 0;
8933 ptr_table_store(PL_ptr_table, &proto_perl->Isv_no, &PL_sv_no);
8936 SvUPGRADE(&PL_sv_yes, SVt_PVNV);
8938 SvANY(&PL_sv_yes) = new_XPVNV();
8940 SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
8941 SvFLAGS(&PL_sv_yes) = SVp_NOK|SVf_NOK|SVp_POK|SVf_POK|SVf_READONLY|SVt_PVNV;
8942 SvPVX(&PL_sv_yes) = SAVEPVN(PL_Yes, 1);
8943 SvCUR(&PL_sv_yes) = 1;
8944 SvLEN(&PL_sv_yes) = 2;
8945 SvNVX(&PL_sv_yes) = 1;
8946 ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes);
8948 /* create shared string table */
8949 PL_strtab = newHV();
8950 HvSHAREKEYS_off(PL_strtab);
8951 hv_ksplit(PL_strtab, 512);
8952 ptr_table_store(PL_ptr_table, proto_perl->Istrtab, PL_strtab);
8954 PL_compiling = proto_perl->Icompiling;
8955 PL_compiling.cop_stashpv = SAVEPV(PL_compiling.cop_stashpv);
8956 PL_compiling.cop_file = SAVEPV(PL_compiling.cop_file);
8957 ptr_table_store(PL_ptr_table, &proto_perl->Icompiling, &PL_compiling);
8958 if (!specialWARN(PL_compiling.cop_warnings))
8959 PL_compiling.cop_warnings = sv_dup_inc(PL_compiling.cop_warnings);
8960 if (!specialCopIO(PL_compiling.cop_io))
8961 PL_compiling.cop_io = sv_dup_inc(PL_compiling.cop_io);
8962 PL_curcop = (COP*)any_dup(proto_perl->Tcurcop, proto_perl);
8964 /* pseudo environmental stuff */
8965 PL_origargc = proto_perl->Iorigargc;
8967 New(0, PL_origargv, i+1, char*);
8968 PL_origargv[i] = '\0';
8970 PL_origargv[i] = SAVEPV(proto_perl->Iorigargv[i]);
8972 PL_envgv = gv_dup(proto_perl->Ienvgv);
8973 PL_incgv = gv_dup(proto_perl->Iincgv);
8974 PL_hintgv = gv_dup(proto_perl->Ihintgv);
8975 PL_origfilename = SAVEPV(proto_perl->Iorigfilename);
8976 PL_diehook = sv_dup_inc(proto_perl->Idiehook);
8977 PL_warnhook = sv_dup_inc(proto_perl->Iwarnhook);
8980 PL_minus_c = proto_perl->Iminus_c;
8981 PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel);
8982 PL_localpatches = proto_perl->Ilocalpatches;
8983 PL_splitstr = proto_perl->Isplitstr;
8984 PL_preprocess = proto_perl->Ipreprocess;
8985 PL_minus_n = proto_perl->Iminus_n;
8986 PL_minus_p = proto_perl->Iminus_p;
8987 PL_minus_l = proto_perl->Iminus_l;
8988 PL_minus_a = proto_perl->Iminus_a;
8989 PL_minus_F = proto_perl->Iminus_F;
8990 PL_doswitches = proto_perl->Idoswitches;
8991 PL_dowarn = proto_perl->Idowarn;
8992 PL_doextract = proto_perl->Idoextract;
8993 PL_sawampersand = proto_perl->Isawampersand;
8994 PL_unsafe = proto_perl->Iunsafe;
8995 PL_inplace = SAVEPV(proto_perl->Iinplace);
8996 PL_e_script = sv_dup_inc(proto_perl->Ie_script);
8997 PL_perldb = proto_perl->Iperldb;
8998 PL_perl_destruct_level = proto_perl->Iperl_destruct_level;
9000 /* magical thingies */
9001 /* XXX time(&PL_basetime) when asked for? */
9002 PL_basetime = proto_perl->Ibasetime;
9003 PL_formfeed = sv_dup(proto_perl->Iformfeed);
9005 PL_maxsysfd = proto_perl->Imaxsysfd;
9006 PL_multiline = proto_perl->Imultiline;
9007 PL_statusvalue = proto_perl->Istatusvalue;
9009 PL_statusvalue_vms = proto_perl->Istatusvalue_vms;
9012 /* shortcuts to various I/O objects */
9013 PL_stdingv = gv_dup(proto_perl->Istdingv);
9014 PL_stderrgv = gv_dup(proto_perl->Istderrgv);
9015 PL_defgv = gv_dup(proto_perl->Idefgv);
9016 PL_argvgv = gv_dup(proto_perl->Iargvgv);
9017 PL_argvoutgv = gv_dup(proto_perl->Iargvoutgv);
9018 PL_argvout_stack = av_dup_inc(proto_perl->Iargvout_stack);
9020 /* shortcuts to regexp stuff */
9021 PL_replgv = gv_dup(proto_perl->Ireplgv);
9023 /* shortcuts to misc objects */
9024 PL_errgv = gv_dup(proto_perl->Ierrgv);
9026 /* shortcuts to debugging objects */
9027 PL_DBgv = gv_dup(proto_perl->IDBgv);
9028 PL_DBline = gv_dup(proto_perl->IDBline);
9029 PL_DBsub = gv_dup(proto_perl->IDBsub);
9030 PL_DBsingle = sv_dup(proto_perl->IDBsingle);
9031 PL_DBtrace = sv_dup(proto_perl->IDBtrace);
9032 PL_DBsignal = sv_dup(proto_perl->IDBsignal);
9033 PL_lineary = av_dup(proto_perl->Ilineary);
9034 PL_dbargs = av_dup(proto_perl->Idbargs);
9037 PL_defstash = hv_dup_inc(proto_perl->Tdefstash);
9038 PL_curstash = hv_dup(proto_perl->Tcurstash);
9039 PL_debstash = hv_dup(proto_perl->Idebstash);
9040 PL_globalstash = hv_dup(proto_perl->Iglobalstash);
9041 PL_curstname = sv_dup_inc(proto_perl->Icurstname);
9043 PL_beginav = av_dup_inc(proto_perl->Ibeginav);
9044 PL_endav = av_dup_inc(proto_perl->Iendav);
9045 PL_checkav = av_dup_inc(proto_perl->Icheckav);
9046 PL_initav = av_dup_inc(proto_perl->Iinitav);
9048 PL_sub_generation = proto_perl->Isub_generation;
9050 /* funky return mechanisms */
9051 PL_forkprocess = proto_perl->Iforkprocess;
9053 /* subprocess state */
9054 PL_fdpid = av_dup_inc(proto_perl->Ifdpid);
9056 /* internal state */
9057 PL_tainting = proto_perl->Itainting;
9058 PL_maxo = proto_perl->Imaxo;
9059 if (proto_perl->Iop_mask)
9060 PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo);
9062 PL_op_mask = Nullch;
9064 /* current interpreter roots */
9065 PL_main_cv = cv_dup_inc(proto_perl->Imain_cv);
9066 PL_main_root = OpREFCNT_inc(proto_perl->Imain_root);
9067 PL_main_start = proto_perl->Imain_start;
9068 PL_eval_root = proto_perl->Ieval_root;
9069 PL_eval_start = proto_perl->Ieval_start;
9071 /* runtime control stuff */
9072 PL_curcopdb = (COP*)any_dup(proto_perl->Icurcopdb, proto_perl);
9073 PL_copline = proto_perl->Icopline;
9075 PL_filemode = proto_perl->Ifilemode;
9076 PL_lastfd = proto_perl->Ilastfd;
9077 PL_oldname = proto_perl->Ioldname; /* XXX not quite right */
9080 PL_gensym = proto_perl->Igensym;
9081 PL_preambled = proto_perl->Ipreambled;
9082 PL_preambleav = av_dup_inc(proto_perl->Ipreambleav);
9083 PL_laststatval = proto_perl->Ilaststatval;
9084 PL_laststype = proto_perl->Ilaststype;
9085 PL_mess_sv = Nullsv;
9087 PL_ors_sv = sv_dup_inc(proto_perl->Iors_sv);
9088 PL_ofmt = SAVEPV(proto_perl->Iofmt);
9090 /* interpreter atexit processing */
9091 PL_exitlistlen = proto_perl->Iexitlistlen;
9092 if (PL_exitlistlen) {
9093 New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9094 Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry);
9097 PL_exitlist = (PerlExitListEntry*)NULL;
9098 PL_modglobal = hv_dup_inc(proto_perl->Imodglobal);
9100 PL_profiledata = NULL;
9101 PL_rsfp = fp_dup(proto_perl->Irsfp, '<');
9102 /* PL_rsfp_filters entries have fake IoDIRP() */
9103 PL_rsfp_filters = av_dup_inc(proto_perl->Irsfp_filters);
9105 PL_compcv = cv_dup(proto_perl->Icompcv);
9106 PL_comppad = av_dup(proto_perl->Icomppad);
9107 PL_comppad_name = av_dup(proto_perl->Icomppad_name);
9108 PL_comppad_name_fill = proto_perl->Icomppad_name_fill;
9109 PL_comppad_name_floor = proto_perl->Icomppad_name_floor;
9110 PL_curpad = (SV**)ptr_table_fetch(PL_ptr_table,
9111 proto_perl->Tcurpad);
9113 #ifdef HAVE_INTERP_INTERN
9114 sys_intern_dup(&proto_perl->Isys_intern, &PL_sys_intern);
9117 /* more statics moved here */
9118 PL_generation = proto_perl->Igeneration;
9119 PL_DBcv = cv_dup(proto_perl->IDBcv);
9121 PL_in_clean_objs = proto_perl->Iin_clean_objs;
9122 PL_in_clean_all = proto_perl->Iin_clean_all;
9124 PL_uid = proto_perl->Iuid;
9125 PL_euid = proto_perl->Ieuid;
9126 PL_gid = proto_perl->Igid;
9127 PL_egid = proto_perl->Iegid;
9128 PL_nomemok = proto_perl->Inomemok;
9129 PL_an = proto_perl->Ian;
9130 PL_cop_seqmax = proto_perl->Icop_seqmax;
9131 PL_op_seqmax = proto_perl->Iop_seqmax;
9132 PL_evalseq = proto_perl->Ievalseq;
9133 PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */
9134 PL_origalen = proto_perl->Iorigalen;
9135 PL_pidstatus = newHV(); /* XXX flag for cloning? */
9136 PL_osname = SAVEPV(proto_perl->Iosname);
9137 PL_sh_path = SAVEPV(proto_perl->Ish_path);
9138 PL_sighandlerp = proto_perl->Isighandlerp;
9141 PL_runops = proto_perl->Irunops;
9143 Copy(proto_perl->Itokenbuf, PL_tokenbuf, 256, char);
9146 PL_cshlen = proto_perl->Icshlen;
9147 PL_cshname = SAVEPVN(proto_perl->Icshname, PL_cshlen);
9150 PL_lex_state = proto_perl->Ilex_state;
9151 PL_lex_defer = proto_perl->Ilex_defer;
9152 PL_lex_expect = proto_perl->Ilex_expect;
9153 PL_lex_formbrack = proto_perl->Ilex_formbrack;
9154 PL_lex_dojoin = proto_perl->Ilex_dojoin;
9155 PL_lex_starts = proto_perl->Ilex_starts;
9156 PL_lex_stuff = sv_dup_inc(proto_perl->Ilex_stuff);
9157 PL_lex_repl = sv_dup_inc(proto_perl->Ilex_repl);
9158 PL_lex_op = proto_perl->Ilex_op;
9159 PL_lex_inpat = proto_perl->Ilex_inpat;
9160 PL_lex_inwhat = proto_perl->Ilex_inwhat;
9161 PL_lex_brackets = proto_perl->Ilex_brackets;
9162 i = (PL_lex_brackets < 120 ? 120 : PL_lex_brackets);
9163 PL_lex_brackstack = SAVEPVN(proto_perl->Ilex_brackstack,i);
9164 PL_lex_casemods = proto_perl->Ilex_casemods;
9165 i = (PL_lex_casemods < 12 ? 12 : PL_lex_casemods);
9166 PL_lex_casestack = SAVEPVN(proto_perl->Ilex_casestack,i);
9168 Copy(proto_perl->Inextval, PL_nextval, 5, YYSTYPE);
9169 Copy(proto_perl->Inexttype, PL_nexttype, 5, I32);
9170 PL_nexttoke = proto_perl->Inexttoke;
9172 PL_linestr = sv_dup_inc(proto_perl->Ilinestr);
9173 i = proto_perl->Ibufptr - SvPVX(proto_perl->Ilinestr);
9174 PL_bufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9175 i = proto_perl->Ioldbufptr - SvPVX(proto_perl->Ilinestr);
9176 PL_oldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9177 i = proto_perl->Ioldoldbufptr - SvPVX(proto_perl->Ilinestr);
9178 PL_oldoldbufptr = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9179 PL_bufend = SvPVX(PL_linestr) + SvCUR(PL_linestr);
9180 i = proto_perl->Ilinestart - SvPVX(proto_perl->Ilinestr);
9181 PL_linestart = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9182 PL_pending_ident = proto_perl->Ipending_ident;
9183 PL_sublex_info = proto_perl->Isublex_info; /* XXX not quite right */
9185 PL_expect = proto_perl->Iexpect;
9187 PL_multi_start = proto_perl->Imulti_start;
9188 PL_multi_end = proto_perl->Imulti_end;
9189 PL_multi_open = proto_perl->Imulti_open;
9190 PL_multi_close = proto_perl->Imulti_close;
9192 PL_error_count = proto_perl->Ierror_count;
9193 PL_subline = proto_perl->Isubline;
9194 PL_subname = sv_dup_inc(proto_perl->Isubname);
9196 PL_min_intro_pending = proto_perl->Imin_intro_pending;
9197 PL_max_intro_pending = proto_perl->Imax_intro_pending;
9198 PL_padix = proto_perl->Ipadix;
9199 PL_padix_floor = proto_perl->Ipadix_floor;
9200 PL_pad_reset_pending = proto_perl->Ipad_reset_pending;
9202 i = proto_perl->Ilast_uni - SvPVX(proto_perl->Ilinestr);
9203 PL_last_uni = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9204 i = proto_perl->Ilast_lop - SvPVX(proto_perl->Ilinestr);
9205 PL_last_lop = SvPVX(PL_linestr) + (i < 0 ? 0 : i);
9206 PL_last_lop_op = proto_perl->Ilast_lop_op;
9207 PL_in_my = proto_perl->Iin_my;
9208 PL_in_my_stash = hv_dup(proto_perl->Iin_my_stash);
9210 PL_cryptseen = proto_perl->Icryptseen;
9213 PL_hints = proto_perl->Ihints;
9215 PL_amagic_generation = proto_perl->Iamagic_generation;
9217 #ifdef USE_LOCALE_COLLATE
9218 PL_collation_ix = proto_perl->Icollation_ix;
9219 PL_collation_name = SAVEPV(proto_perl->Icollation_name);
9220 PL_collation_standard = proto_perl->Icollation_standard;
9221 PL_collxfrm_base = proto_perl->Icollxfrm_base;
9222 PL_collxfrm_mult = proto_perl->Icollxfrm_mult;
9223 #endif /* USE_LOCALE_COLLATE */
9225 #ifdef USE_LOCALE_NUMERIC
9226 PL_numeric_name = SAVEPV(proto_perl->Inumeric_name);
9227 PL_numeric_standard = proto_perl->Inumeric_standard;
9228 PL_numeric_local = proto_perl->Inumeric_local;
9229 PL_numeric_radix_sv = sv_dup_inc(proto_perl->Inumeric_radix_sv);
9230 #endif /* !USE_LOCALE_NUMERIC */
9232 /* utf8 character classes */
9233 PL_utf8_alnum = sv_dup_inc(proto_perl->Iutf8_alnum);
9234 PL_utf8_alnumc = sv_dup_inc(proto_perl->Iutf8_alnumc);
9235 PL_utf8_ascii = sv_dup_inc(proto_perl->Iutf8_ascii);
9236 PL_utf8_alpha = sv_dup_inc(proto_perl->Iutf8_alpha);
9237 PL_utf8_space = sv_dup_inc(proto_perl->Iutf8_space);
9238 PL_utf8_cntrl = sv_dup_inc(proto_perl->Iutf8_cntrl);
9239 PL_utf8_graph = sv_dup_inc(proto_perl->Iutf8_graph);
9240 PL_utf8_digit = sv_dup_inc(proto_perl->Iutf8_digit);
9241 PL_utf8_upper = sv_dup_inc(proto_perl->Iutf8_upper);
9242 PL_utf8_lower = sv_dup_inc(proto_perl->Iutf8_lower);
9243 PL_utf8_print = sv_dup_inc(proto_perl->Iutf8_print);
9244 PL_utf8_punct = sv_dup_inc(proto_perl->Iutf8_punct);
9245 PL_utf8_xdigit = sv_dup_inc(proto_perl->Iutf8_xdigit);
9246 PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark);
9247 PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper);
9248 PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle);
9249 PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower);
9252 PL_last_swash_hv = Nullhv; /* reinits on demand */
9253 PL_last_swash_klen = 0;
9254 PL_last_swash_key[0]= '\0';
9255 PL_last_swash_tmps = (U8*)NULL;
9256 PL_last_swash_slen = 0;
9258 /* perly.c globals */
9259 PL_yydebug = proto_perl->Iyydebug;
9260 PL_yynerrs = proto_perl->Iyynerrs;
9261 PL_yyerrflag = proto_perl->Iyyerrflag;
9262 PL_yychar = proto_perl->Iyychar;
9263 PL_yyval = proto_perl->Iyyval;
9264 PL_yylval = proto_perl->Iyylval;
9266 PL_glob_index = proto_perl->Iglob_index;
9267 PL_srand_called = proto_perl->Isrand_called;
9268 PL_uudmap['M'] = 0; /* reinits on demand */
9269 PL_bitcount = Nullch; /* reinits on demand */
9271 if (proto_perl->Ipsig_pend) {
9272 Newz(0, PL_psig_pend, SIG_SIZE, int);
9275 PL_psig_pend = (int*)NULL;
9278 if (proto_perl->Ipsig_ptr) {
9279 Newz(0, PL_psig_ptr, SIG_SIZE, SV*);
9280 Newz(0, PL_psig_name, SIG_SIZE, SV*);
9281 for (i = 1; i < SIG_SIZE; i++) {
9282 PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i]);
9283 PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i]);
9287 PL_psig_ptr = (SV**)NULL;
9288 PL_psig_name = (SV**)NULL;
9291 /* thrdvar.h stuff */
9293 if (flags & CLONEf_COPY_STACKS) {
9294 /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */
9295 PL_tmps_ix = proto_perl->Ttmps_ix;
9296 PL_tmps_max = proto_perl->Ttmps_max;
9297 PL_tmps_floor = proto_perl->Ttmps_floor;
9298 Newz(50, PL_tmps_stack, PL_tmps_max, SV*);
9300 while (i <= PL_tmps_ix) {
9301 PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i]);
9305 /* next PUSHMARK() sets *(PL_markstack_ptr+1) */
9306 i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack;
9307 Newz(54, PL_markstack, i, I32);
9308 PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max
9309 - proto_perl->Tmarkstack);
9310 PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr
9311 - proto_perl->Tmarkstack);
9312 Copy(proto_perl->Tmarkstack, PL_markstack,
9313 PL_markstack_ptr - PL_markstack + 1, I32);
9315 /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix]
9316 * NOTE: unlike the others! */
9317 PL_scopestack_ix = proto_perl->Tscopestack_ix;
9318 PL_scopestack_max = proto_perl->Tscopestack_max;
9319 Newz(54, PL_scopestack, PL_scopestack_max, I32);
9320 Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32);
9322 /* next push_return() sets PL_retstack[PL_retstack_ix]
9323 * NOTE: unlike the others! */
9324 PL_retstack_ix = proto_perl->Tretstack_ix;
9325 PL_retstack_max = proto_perl->Tretstack_max;
9326 Newz(54, PL_retstack, PL_retstack_max, OP*);
9327 Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32);
9329 /* NOTE: si_dup() looks at PL_markstack */
9330 PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo);
9332 /* PL_curstack = PL_curstackinfo->si_stack; */
9333 PL_curstack = av_dup(proto_perl->Tcurstack);
9334 PL_mainstack = av_dup(proto_perl->Tmainstack);
9336 /* next PUSHs() etc. set *(PL_stack_sp+1) */
9337 PL_stack_base = AvARRAY(PL_curstack);
9338 PL_stack_sp = PL_stack_base + (proto_perl->Tstack_sp
9339 - proto_perl->Tstack_base);
9340 PL_stack_max = PL_stack_base + AvMAX(PL_curstack);
9342 /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix]
9343 * NOTE: unlike the others! */
9344 PL_savestack_ix = proto_perl->Tsavestack_ix;
9345 PL_savestack_max = proto_perl->Tsavestack_max;
9346 /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/
9347 PL_savestack = ss_dup(proto_perl);
9351 ENTER; /* perl_destruct() wants to LEAVE; */
9354 PL_start_env = proto_perl->Tstart_env; /* XXXXXX */
9355 PL_top_env = &PL_start_env;
9357 PL_op = proto_perl->Top;
9360 PL_Xpv = (XPV*)NULL;
9361 PL_na = proto_perl->Tna;
9363 PL_statbuf = proto_perl->Tstatbuf;
9364 PL_statcache = proto_perl->Tstatcache;
9365 PL_statgv = gv_dup(proto_perl->Tstatgv);
9366 PL_statname = sv_dup_inc(proto_perl->Tstatname);
9368 PL_timesbuf = proto_perl->Ttimesbuf;
9371 PL_tainted = proto_perl->Ttainted;
9372 PL_curpm = proto_perl->Tcurpm; /* XXX No PMOP ref count */
9373 PL_nrs = sv_dup_inc(proto_perl->Tnrs);
9374 PL_rs = sv_dup_inc(proto_perl->Trs);
9375 PL_last_in_gv = gv_dup(proto_perl->Tlast_in_gv);
9376 PL_ofs_sv = sv_dup_inc(proto_perl->Tofs_sv);
9377 PL_defoutgv = gv_dup_inc(proto_perl->Tdefoutgv);
9378 PL_chopset = proto_perl->Tchopset; /* XXX never deallocated */
9379 PL_toptarget = sv_dup_inc(proto_perl->Ttoptarget);
9380 PL_bodytarget = sv_dup_inc(proto_perl->Tbodytarget);
9381 PL_formtarget = sv_dup(proto_perl->Tformtarget);
9383 PL_restartop = proto_perl->Trestartop;
9384 PL_in_eval = proto_perl->Tin_eval;
9385 PL_delaymagic = proto_perl->Tdelaymagic;
9386 PL_dirty = proto_perl->Tdirty;
9387 PL_localizing = proto_perl->Tlocalizing;
9389 #ifdef PERL_FLEXIBLE_EXCEPTIONS
9390 PL_protect = proto_perl->Tprotect;
9392 PL_errors = sv_dup_inc(proto_perl->Terrors);
9393 PL_av_fetch_sv = Nullsv;
9394 PL_hv_fetch_sv = Nullsv;
9395 Zero(&PL_hv_fetch_ent_mh, 1, HE); /* XXX */
9396 PL_modcount = proto_perl->Tmodcount;
9397 PL_lastgotoprobe = Nullop;
9398 PL_dumpindent = proto_perl->Tdumpindent;
9400 PL_sortcop = (OP*)any_dup(proto_perl->Tsortcop, proto_perl);
9401 PL_sortstash = hv_dup(proto_perl->Tsortstash);
9402 PL_firstgv = gv_dup(proto_perl->Tfirstgv);
9403 PL_secondgv = gv_dup(proto_perl->Tsecondgv);
9404 PL_sortcxix = proto_perl->Tsortcxix;
9405 PL_efloatbuf = Nullch; /* reinits on demand */
9406 PL_efloatsize = 0; /* reinits on demand */
9410 PL_screamfirst = NULL;
9411 PL_screamnext = NULL;
9412 PL_maxscream = -1; /* reinits on demand */
9413 PL_lastscream = Nullsv;
9415 PL_watchaddr = NULL;
9416 PL_watchok = Nullch;
9418 PL_regdummy = proto_perl->Tregdummy;
9419 PL_regcomp_parse = Nullch;
9420 PL_regxend = Nullch;
9421 PL_regcode = (regnode*)NULL;
9424 PL_regprecomp = Nullch;
9429 PL_seen_zerolen = 0;
9431 PL_regcomp_rx = (regexp*)NULL;
9433 PL_colorset = 0; /* reinits PL_colors[] */
9434 /*PL_colors[6] = {0,0,0,0,0,0};*/
9435 PL_reg_whilem_seen = 0;
9436 PL_reginput = Nullch;
9439 PL_regstartp = (I32*)NULL;
9440 PL_regendp = (I32*)NULL;
9441 PL_reglastparen = (U32*)NULL;
9442 PL_regtill = Nullch;
9443 PL_reg_start_tmp = (char**)NULL;
9444 PL_reg_start_tmpl = 0;
9445 PL_regdata = (struct reg_data*)NULL;
9448 PL_reg_eval_set = 0;
9450 PL_regprogram = (regnode*)NULL;
9452 PL_regcc = (CURCUR*)NULL;
9453 PL_reg_call_cc = (struct re_cc_state*)NULL;
9454 PL_reg_re = (regexp*)NULL;
9455 PL_reg_ganch = Nullch;
9457 PL_reg_magic = (MAGIC*)NULL;
9459 PL_reg_oldcurpm = (PMOP*)NULL;
9460 PL_reg_curpm = (PMOP*)NULL;
9461 PL_reg_oldsaved = Nullch;
9462 PL_reg_oldsavedlen = 0;
9464 PL_reg_leftiter = 0;
9465 PL_reg_poscache = Nullch;
9466 PL_reg_poscache_size= 0;
9468 /* RE engine - function pointers */
9469 PL_regcompp = proto_perl->Tregcompp;
9470 PL_regexecp = proto_perl->Tregexecp;
9471 PL_regint_start = proto_perl->Tregint_start;
9472 PL_regint_string = proto_perl->Tregint_string;
9473 PL_regfree = proto_perl->Tregfree;
9475 PL_reginterp_cnt = 0;
9476 PL_reg_starttry = 0;
9478 if (!(flags & CLONEf_KEEP_PTR_TABLE)) {
9479 ptr_table_free(PL_ptr_table);
9480 PL_ptr_table = NULL;
9484 return (PerlInterpreter*)pPerl;
9490 #else /* !USE_ITHREADS */
9496 #endif /* USE_ITHREADS */
9499 do_report_used(pTHXo_ SV *sv)
9501 if (SvTYPE(sv) != SVTYPEMASK) {
9502 PerlIO_printf(Perl_debug_log, "****\n");
9508 do_clean_objs(pTHXo_ SV *sv)
9512 if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) {
9513 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv)));
9514 if (SvWEAKREF(sv)) {
9525 /* XXX Might want to check arrays, etc. */
9528 #ifndef DISABLE_DESTRUCTOR_KLUDGE
9530 do_clean_named_objs(pTHXo_ SV *sv)
9532 if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) {
9533 if ( SvOBJECT(GvSV(sv)) ||
9534 (GvAV(sv) && SvOBJECT(GvAV(sv))) ||
9535 (GvHV(sv) && SvOBJECT(GvHV(sv))) ||
9536 (GvIO(sv) && SvOBJECT(GvIO(sv))) ||
9537 (GvCV(sv) && SvOBJECT(GvCV(sv))) )
9539 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv)));
9547 do_clean_all(pTHXo_ SV *sv)
9549 DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) ));
9550 SvFLAGS(sv) |= SVf_BREAK;